diff --git a/Makefile b/Makefile index 5eef59a1d4..234ee71cc2 100644 --- a/Makefile +++ b/Makefile @@ -18,10 +18,10 @@ change-deps: sed -i'.old' '/host-/d' hazel.opam.locked # remove host- lines which are arch-specific. Not using -i '' because of portability issues https://stackoverflow.com/questions/4247068/sed-command-with-i-option-failing-on-mac-but-works-on-linux setup-instructor: - cp src/haz3lweb/ExerciseSettings_instructor.re src/haz3lweb/ExerciseSettings.re + cp src/haz3lweb/exercises/settings/ExerciseSettings_instructor.re src/haz3lweb/exercises/settings/ExerciseSettings.re setup-student: - cp src/haz3lweb/ExerciseSettings_student.re src/haz3lweb/ExerciseSettings.re + cp src/haz3lweb/exercises/settings/ExerciseSettings_student.re src/haz3lweb/exercises/settings/ExerciseSettings.re dev-helper: dune fmt --auto-promote || true diff --git a/docs/ui-architecture.md b/docs/ui-architecture.md new file mode 100644 index 0000000000..119c29ddda --- /dev/null +++ b/docs/ui-architecture.md @@ -0,0 +1,90 @@ +# UI Architecture Guide + +Last updated 2024-11-22 + +Since [#1297](https://github.com/hazelgrove/hazel/pull/1297), the UI portion of Hazel is split into components, where each component is a file that follows the following format with inner modules: + +```reason +module Model { ... } + +module Update { ... } + +(optional) +module Selection { ... } + +module View { ... } + +``` + +This roughly follows the elm architecture for an application where +* an application's current state is stored using a `Model.t`, +* an `Update.update` function takes an action (`Update.t`) and a `Model.t` and returns the next `Model.t` +* a `View.view` function takes the current state of the model, and returns a virtual DOM (our representation of HTML) + + + +## What goes in the `Model.t`? + +Anything that describes the current state of the Hazel editor goes in `Model.t`. This includes: + +* The `Model.t` of subcomponents + +* Any values that can be directly manipulated by the user (Often annotated with a `\\ UPDATED` comment) + +* Anything we don't want to recalculate every redraw (Often annotated with a `\\ CALCULATED` comment) + +If the `Model.t` includes some things that we may not want to save (e.g. the typing information of the current editor), as well as `Model.t`, we also include a similar `Model.persistent` type, along with functions `Model.persist` and `Model.unpersist` to convert. + +## `Update.update` and `Update.calculate` + +Inside the `Update` module, there are two important functions: + +`Update.update : (~settings: Settings.t, Update.t, Model.t) -> Updated.t(Model.t)` + +`Update.calculate : (~settings: Settings.t, Model.t, ...) -> Model.t` + +The `update` function always runs first, and makes minimal changes to record the intention of the user in the model. (e.g. if the user types some text, add the text to the segment). The `calculate` function runs next and and works out all the downstream changes. (e.g. updating the statics, and starting evaluation), + +These two functions are separated for a couple reasons: + +* An `update` on some specific ui element in the program may want to trigger a `calculate` everywhere else in the app (e.g. to re-evaluate the user's program). + +* Looking to the future, we will want to eventually use the Bonsai library to incrementalize the `calculate` step. + +The result of `Update.update` is wrapped in a `Updated.t(...)` which, among other things, records whether the entire app should recalculate after this change. If you return `Updated.return(model)` it will recalculate, and if you return `Updated.return_quiet(model)` it won't recalculate. If you're not sure it's generally safer to use `return`. Look at the optional arguments on `return` if you want more control over what gets recalculated. + +## Selection + +The `Selection` module is only required if it's possible for this component or a component inside this component to be active (i.e. has the cursor, takes key events). + +`Selection.t` is a data structure that can store where within this component the selection currently is. + +The other functions in `Selection` help the app make decisions based on the current selection, e.g. what to do on key presses, what type to show at the bottom of the screen. + +## View + +The view function usually has the following signature: + +``` +let view = + ( + ~globals, + ~selected: option(Selection.t), + ~inject: Update.t => Ui_effect.t(unit), + ~signal: event => Ui_effect.t(unit), + model: Model.t, + ) => Node.t +``` + +`~globals` provides access to global values such as settings, fonts, etc. + +`~selected` tells you whether the current element is selected + +`~inject` lets you perform an update action at this component, e.g. in response to a click or other user input + +`~signal` is a way to propagate events, such as clicks, upwards to this component's parent. + +## The Future + +This system could be viewed as an in-between state, between the original implementation (with one large model and update type) and a fully-incremental Bonsai implementation (where subcomponent inclusion and downstream calculation are handled fully by Bonsai). + diff --git a/src/haz3lcore/dynamics/Builtins.re b/src/haz3lcore/dynamics/Builtins.re index c47617edc6..96b936e3f8 100644 --- a/src/haz3lcore/dynamics/Builtins.re +++ b/src/haz3lcore/dynamics/Builtins.re @@ -264,14 +264,25 @@ module Pervasives = { } ); - let string_sub = _ => + let string_sub = name => ternary((d1, d2, d3) => switch (term_of(d1), term_of(d2), term_of(d3)) { | (String(s), Int(idx), Int(len)) => try(Ok(String(String.sub(s, idx, len)) |> fresh)) { | _ => // TODO: make it clear that the problem could be with d3 too - Ok(DynamicErrorHole(d2, IndexOutOfBounds) |> fresh) + Ok( + DynamicErrorHole( + Ap( + Forward, + BuiltinFun(name) |> fresh, + Tuple([d1, d2, d3]) |> fresh, + ) + |> fresh, + IndexOutOfBounds, + ) + |> fresh, + ) } | (String(_), Int(_), _) => Error(InvalidBoxedIntLit(d3)) | (String(_), _, _) => Error(InvalidBoxedIntLit(d2)) diff --git a/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index a69f560dd5..41f96822df 100644 --- a/src/haz3lcore/dynamics/Casts.re +++ b/src/haz3lcore/dynamics/Casts.re @@ -125,19 +125,28 @@ let rec transition = (~recursive=false, d: DHExp.t): option(DHExp.t) => { | (Hole, NotGroundOrHole(t2_grounded)) => /* ITExpand rule */ - let inner_cast = Cast(d1, t1, t2_grounded) |> DHExp.fresh; + let inner_cast = + Cast(d1, t1, t2_grounded |> DHExp.replace_all_ids_typ) |> DHExp.fresh; // HACK: we need to check the inner cast here let inner_cast = switch (transition(~recursive, inner_cast)) { | Some(d1) => d1 | None => inner_cast }; - Some(Cast(inner_cast, t2_grounded, t2) |> DHExp.fresh); + Some( + Cast(inner_cast, t2_grounded |> DHExp.replace_all_ids_typ, t2) + |> DHExp.fresh, + ); | (NotGroundOrHole(t1_grounded), Hole) => /* ITGround rule */ Some( - Cast(Cast(d1, t1, t1_grounded) |> DHExp.fresh, t1_grounded, t2) + Cast( + Cast(d1, t1, t1_grounded |> DHExp.replace_all_ids_typ) + |> DHExp.fresh, + t1_grounded |> DHExp.replace_all_ids_typ, + t2, + ) |> DHExp.fresh, ) diff --git a/src/haz3lcore/dynamics/DHExp.re b/src/haz3lcore/dynamics/DHExp.re index f7651ba963..e8b46575d0 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -14,16 +14,6 @@ let mk = (ids, term): t => { {ids, copied: true, term}; }; -// TODO: make this function emit a map of changes -let replace_all_ids = - map_term( - ~f_exp=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_pat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_typ=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_tpat=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ~f_rul=(continue, exp) => {...exp, ids: [Id.mk()]} |> continue, - ); - // TODO: make this function emit a map of changes let repair_ids = map_term( @@ -34,6 +24,32 @@ let repair_ids = } else { continue(exp); }, + ~f_typ= + (continue, typ) => + if (Typ.rep_id(typ) == Id.invalid) { + replace_all_ids_typ(typ); + } else { + continue(typ); + }, + _, + ); + +let repair_ids_typ = + Typ.map_term( + ~f_exp= + (continue, exp) => + if (Exp.rep_id(exp) == Id.invalid) { + replace_all_ids(exp); + } else { + continue(exp); + }, + ~f_typ= + (continue, typ) => + if (typ.copied) { + replace_all_ids_typ(typ); + } else { + continue(typ); + }, _, ); @@ -79,8 +95,9 @@ let rec strip_casts = | Undefined | If(_) => continue(exp) /* Remove casts*/ - | FailedCast(d, _, _) | Cast(d, _, _) => strip_casts(d) + /* Keep failed casts*/ + | FailedCast(_, _, _) => continue(exp) } }, _, diff --git a/src/haz3lcore/dynamics/DHPat.re b/src/haz3lcore/dynamics/DHPat.re index f9e4adbddb..84de439da4 100644 --- a/src/haz3lcore/dynamics/DHPat.re +++ b/src/haz3lcore/dynamics/DHPat.re @@ -32,23 +32,3 @@ let rec binds_var = (m: Statics.Map.t, x: Var.t, dp: t): bool => | Ap(_, _) => false } }; - -let rec bound_vars = (dp: t): list(Var.t) => - switch (dp |> term_of) { - | EmptyHole - | MultiHole(_) - | Wild - | Invalid(_) - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | Constructor(_) => [] - | Cast(y, _, _) - | Parens(y) => bound_vars(y) - | Var(y) => [y] - | Tuple(dps) => List.flatten(List.map(bound_vars, dps)) - | Cons(dp1, dp2) => bound_vars(dp1) @ bound_vars(dp2) - | ListLit(dps) => List.flatten(List.map(bound_vars, dps)) - | Ap(_, dp1) => bound_vars(dp1) - }; diff --git a/src/haz3lcore/dynamics/Evaluator.re b/src/haz3lcore/dynamics/Evaluator.re index 628b493e1d..fc4027f4d6 100644 --- a/src/haz3lcore/dynamics/Evaluator.re +++ b/src/haz3lcore/dynamics/Evaluator.re @@ -1,25 +1,6 @@ open Transition; -module Result = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | BoxedValue(DHExp.t) - | Indet(DHExp.t); - - let unbox = - fun - | BoxedValue(d) - | Indet(d) => d; - - let fast_equal = (r1, r2) => - switch (r1, r2) { - | (BoxedValue(d1), BoxedValue(d2)) - | (Indet(d1), Indet(d2)) => DHExp.fast_equal(d1, d2) - | _ => false - }; -}; - -open Result; +open ProgramResult.Result; module EvaluatorEVMode: { type status = @@ -133,7 +114,7 @@ let rec evaluate = (state, env, d) => { }; }; -let evaluate = (env, {d}: Elaborator.Elaboration.t) => { +let evaluate' = (env, {d, _}: Elaborator.Elaboration.t) => { let state = ref(EvaluatorState.init); let env = ClosureEnvironment.of_environment(env); let result = evaluate(state, env, d); @@ -145,3 +126,20 @@ let evaluate = (env, {d}: Elaborator.Elaboration.t) => { }; (state^, result); }; + +let evaluate = + (~settings: CoreSettings.t, ~env=Builtins.env_init, elab: DHExp.t) + : ProgramResult.t(ProgramResult.inner) => + switch () { + | _ when !settings.dynamics => Off({d: elab}) + | _ => + switch (evaluate'(env, {d: elab})) { + | exception (EvaluatorError.Exception(reason)) => + print_endline("EvaluatorError:" ++ EvaluatorError.show(reason)); + ResultFail(EvaulatorError(reason)); + | exception exn => + print_endline("EXN:" ++ Printexc.to_string(exn)); + ResultFail(UnknownException(Printexc.to_string(exn))); + | (state, result) => ResultOk({result, state}) + } + }; diff --git a/src/haz3lcore/dynamics/EvaluatorStep.re b/src/haz3lcore/dynamics/EvaluatorStep.re index 0882fa223f..3416a46742 100644 --- a/src/haz3lcore/dynamics/EvaluatorStep.re +++ b/src/haz3lcore/dynamics/EvaluatorStep.re @@ -30,8 +30,187 @@ module EvalObj = { ...obj, ctx: obj.ctx |> f, }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = { + old_id: Id.t, // The id of the term about to be stepped + new_id: Id.t, // The id of the term after it is stepped + knd: step_kind, + }; +}; + +let rec matches = + ( + env: ClosureEnvironment.t, + flt: FilterEnvironment.t, + ctx: EvalCtx.t, + exp: DHExp.t, + act: FilterAction.t, + idx: int, + ) + : (FilterAction.t, int, EvalCtx.t) => { + let composed = EvalCtx.compose(ctx, exp); + let (pact, pidx) = (act, idx); + let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); + let (act, idx) = + switch (ctx) { + | Term({term: Filter(_, _), _}) => (pact, pidx) + | _ => midx > pidx ? (mact, midx) : (pact, pidx) + }; + let map = ((a, i, c), f) => { + (a, i, f(c)); + }; + let (let+) = map; + let (ract, ridx, rctx) = + switch (ctx) { + | Mark => (act, idx, EvalCtx.Mark) + | Term({term, ids}) => + let rewrap = term => EvalCtx.Term({term, ids}); + switch ((term: EvalCtx.term)) { + | Closure(env, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Closure(env, ctx) |> rewrap; + | Filter(Filter(flt'), ctx) => + let flt = flt |> FilterEnvironment.extends(flt'); + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Filter(Filter(flt'), ctx) |> rewrap; + | Filter(Residue(idx, act), ctx) => + let (ract, ridx, rctx) = matches(env, flt, ctx, exp, act, idx); + if (ridx == idx && ract |> snd == All) { + (ract, ridx, Filter(Residue(idx, act), rctx) |> rewrap); + } else { + (ract, ridx, rctx); + }; + | Seq1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Seq1(ctx, d2) |> rewrap; + | Seq2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Seq2(d1, ctx) |> rewrap; + | Let1(d1, ctx, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Let1(d1, ctx, d3) |> rewrap; + | Let2(d1, d2, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Let2(d1, d2, ctx) |> rewrap; + | Fun(dp, ctx, env', name) => + let+ ctx = + matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); + Fun(dp, ctx, env', name) |> rewrap; + | FixF(name, ctx, env') => + let+ ctx = + matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); + FixF(name, ctx, env') |> rewrap; + | Ap1(dir, ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Ap1(dir, ctx, d2) |> rewrap; + | Ap2(dir, d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Ap2(dir, d1, ctx) |> rewrap; + | TypAp(ctx, ty) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + TypAp(ctx, ty) |> rewrap; + | DeferredAp1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DeferredAp1(ctx, d2) |> rewrap; + | DeferredAp2(d1, ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DeferredAp2(d1, ctx, ds) |> rewrap; + | If1(ctx, d2, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If1(ctx, d2, d3) |> rewrap; + | If2(d1, ctx, d3) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If2(d1, ctx, d3) |> rewrap; + | If3(d1, d2, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + If3(d1, d2, ctx) |> rewrap; + | UnOp(op, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + UnOp(op, ctx) |> rewrap; + | BinOp1(op, ctx, d1) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + BinOp1(op, ctx, d1) |> rewrap; + | BinOp2(op, d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + BinOp2(op, d1, ctx) |> rewrap; + | Tuple(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Tuple(ctx, ds) |> rewrap; + | Test(ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Test(ctx) |> rewrap; + | ListLit(ctx, ds) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListLit(ctx, ds) |> rewrap; + | Cons1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cons1(ctx, d2) |> rewrap; + | Cons2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cons2(d1, ctx) |> rewrap; + | ListConcat1(ctx, d2) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListConcat1(ctx, d2) |> rewrap; + | ListConcat2(d1, ctx) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + ListConcat2(d1, ctx) |> rewrap; + | MultiHole(ctx, (dl, dr)) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MultiHole(ctx, (dl, dr)) |> rewrap; + | Cast(ctx, ty, ty') => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + Cast(ctx, ty, ty') |> rewrap; + | FailedCast(ctx, ty, ty') => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + FailedCast(ctx, ty, ty') |> rewrap; + | DynamicErrorHole(ctx, error) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + DynamicErrorHole(ctx, error) |> rewrap; + | MatchScrut(ctx, rs) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MatchScrut(ctx, rs) |> rewrap; + | MatchRule(scr, p, ctx, rs) => + let+ ctx = matches(env, flt, ctx, exp, act, idx); + MatchRule(scr, p, ctx, rs) |> rewrap; + }; + }; + switch (ctx) { + | Term({term: Filter(_), _}) => (ract, ridx, rctx) + | _ when midx == ridx && midx > pidx && mact |> snd == All => ( + ract, + ridx, + Term({term: Filter(Residue(midx, mact), rctx), ids: [Id.mk()]}), + ) + | _ => (ract, ridx, rctx) + }; }; +let should_hide_eval_obj = + (~settings, x: EvalObj.t): (FilterAction.action, EvalObj.t) => + if (should_hide_step_kind(~settings, x.knd)) { + (Eval, x); + } else { + let (act, _, ctx) = + matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); + switch (act) { + | (Eval, _) => (Eval, {...x, ctx}) + | (Step, _) => (Step, {...x, ctx}) + }; + }; + +let should_hide_step = (~settings, x: step): (FilterAction.action, step) => + if (should_hide_step_kind(~settings, x.knd)) { + (Eval, x); + } else { + let (act, _, ctx) = + matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); + switch (act) { + | (Eval, _) => (Eval, {...x, ctx}) + | (Step, _) => (Step, {...x, ctx}) + }; + }; + module Decompose = { module Result = { type t = @@ -203,7 +382,8 @@ module TakeStep = { module TakeStepEV = Transition(TakeStepEVMode); let take_step = (state, env, d) => - TakeStepEV.transition((_, _, _) => None, state, env, d); + TakeStepEV.transition((_, _, _) => None, state, env, d) + |> Option.map(DHExp.repair_ids); }; let take_step = TakeStep.take_step; @@ -213,221 +393,3 @@ let decompose = (d: DHExp.t, es: EvaluatorState.t) => { let rs = Decompose.decompose(ref(es), env, d); Decompose.Result.unbox(rs); }; - -let rec matches = - ( - env: ClosureEnvironment.t, - flt: FilterEnvironment.t, - ctx: EvalCtx.t, - exp: DHExp.t, - act: FilterAction.t, - idx: int, - ) - : (FilterAction.t, int, EvalCtx.t) => { - let composed = EvalCtx.compose(ctx, exp); - let (pact, pidx) = (act, idx); - let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); - let (act, idx) = - switch (ctx) { - | Term({term: Filter(_, _), _}) => (pact, pidx) - | _ => midx > pidx ? (mact, midx) : (pact, pidx) - }; - let map = ((a, i, c), f: EvalCtx.t => EvalCtx.t) => { - (a, i, f(c)); - }; - let (let+) = map; - let (ract, ridx, rctx) = { - let wrap_ids = (ids, ctx) => EvalCtx.Term({term: ctx, ids}); - switch (ctx) { - | Mark => (act, idx, EvalCtx.Mark) - | Term({term, ids}) => - switch (term) { - | Closure(env, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Closure(env, ctx) |> wrap_ids(ids); - | Filter(Filter(flt'), ctx) => - let flt = flt |> FilterEnvironment.extends(flt'); - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Filter(Filter(flt'), ctx) |> wrap_ids(ids); - | Filter(Residue(idx', act'), ctx) => - let (ract, ridx, rctx) = - if (idx > idx') { - matches(env, flt, ctx, exp, act, idx); - } else { - matches(env, flt, ctx, exp, act', idx'); - }; - if (act' |> snd == All) { - ( - ract, - ridx, - Term({ - term: Filter(Residue(idx', act'), rctx), - ids: [Id.mk()], - }), - ); - } else { - (ract, ridx, rctx); - }; - | Seq1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Seq1(ctx, d2) |> wrap_ids(ids); - | Seq2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Seq2(d1, ctx) |> wrap_ids(ids); - | Let1(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Let1(d1, ctx, d3) |> wrap_ids(ids); - | Let2(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Let2(d1, d2, ctx) |> wrap_ids(ids); - | Fun(dp, ctx, env', name) => - let+ ctx = - matches( - env' |> Option.value(~default=env), - flt, - ctx, - exp, - act, - idx, - ); - Fun(dp, ctx, env', name) |> wrap_ids(ids); - | FixF(name, ctx, env') => - let+ ctx = - matches( - env' |> Option.value(~default=env), - flt, - ctx, - exp, - act, - idx, - ); - FixF(name, ctx, env') |> wrap_ids(ids); - | Ap1(dir, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap1(dir, ctx, d2) |> wrap_ids(ids); - | Ap2(dir, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap2(dir, d1, ctx) |> wrap_ids(ids); - | If1(ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If1(ctx, d2, d3) |> wrap_ids(ids); - | If2(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If2(d1, ctx, d3) |> wrap_ids(ids); - | If3(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If3(d1, d2, ctx) |> wrap_ids(ids); - | BinOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinOp1(op, ctx, d1) |> wrap_ids(ids); - | BinOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinOp2(op, d1, ctx) |> wrap_ids(ids); - | Test(ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Test(ctx) |> wrap_ids(ids); - | ListLit(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListLit(ctx, ds) |> wrap_ids(ids); - | Tuple(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Tuple(ctx, ds) |> wrap_ids(ids); - | MultiHole(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MultiHole(ctx, ds) |> wrap_ids(ids); - | Cons1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cons1(ctx, d2) |> wrap_ids(ids); - | Cons2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cons2(d1, ctx) |> wrap_ids(ids); - | ListConcat1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListConcat1(ctx, d2) |> wrap_ids(ids); - | ListConcat2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListConcat2(d1, ctx) |> wrap_ids(ids); - | Cast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cast(ctx, ty, ty') |> wrap_ids(ids); - | FailedCast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - FailedCast(ctx, ty, ty') |> wrap_ids(ids); - | DynamicErrorHole(ctx, error) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - DynamicErrorHole(ctx, error) |> wrap_ids(ids); - | MatchScrut(ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MatchScrut(ctx, rs) |> wrap_ids(ids); - | MatchRule(dexp, dpat, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MatchRule(dexp, dpat, ctx, rs) |> wrap_ids(ids); - | TypAp(ctx, ty) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - TypAp(ctx, ty) |> wrap_ids(ids); - | DeferredAp1(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - DeferredAp1(ctx, ds) |> wrap_ids(ids); - | DeferredAp2(d1, ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - DeferredAp2(d1, ctx, ds) |> wrap_ids(ids); - | UnOp(op, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - UnOp(op, ctx) |> wrap_ids(ids); - } - }; - }; - switch (ctx) { - | Term({term: Filter(_), _}) => (ract, ridx, rctx) - | _ when midx > pidx && mact |> snd == All => ( - ract, - ridx, - Term({term: Filter(Residue(midx, mact), rctx), ids: [Id.mk()]}), - ) - | _ => (ract, ridx, rctx) - }; -}; - -let should_hide_eval_obj = - (~settings, x: EvalObj.t): (FilterAction.action, EvalObj.t) => - if (should_hide_step_kind(~settings, x.knd)) { - (Eval, x); - } else { - let (act, _, ctx) = - matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); - switch (act) { - | (Eval, _) => (Eval, {...x, ctx}) - | (Step, _) => (Step, {...x, ctx}) - }; - }; - -let should_hide_step = (~settings, x: step): (FilterAction.action, step) => - if (should_hide_step_kind(~settings, x.knd)) { - (Eval, x); - } else { - let (act, _, ctx) = - matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); - switch (act) { - | (Eval, _) => (Eval, {...x, ctx}) - | (Step, _) => (Step, {...x, ctx}) - }; - }; - -let decompose = (~settings, d, st) => - decompose(d, st) |> List.map(should_hide_eval_obj(~settings)); - -let evaluate_with_history = (~settings, d) => { - let state = ref(EvaluatorState.init); - let rec go = d => - switch (decompose(~settings, d, state^)) { - | [] => [] - | [(_, x), ..._] => - switch (take_step(state, x.env, x.d_loc)) { - | None => [] - | Some(d) => - let next = EvalCtx.compose(x.ctx, d); - [next, ...go(next)]; - } - }; - go(d); -}; diff --git a/src/haz3lcore/dynamics/Stepper.re b/src/haz3lcore/dynamics/Stepper.re deleted file mode 100644 index 8b977cdf5f..0000000000 --- a/src/haz3lcore/dynamics/Stepper.re +++ /dev/null @@ -1,442 +0,0 @@ -open EvaluatorStep; -open Transition; -open Util; - -exception Exception; - -[@deriving (show({with_path: false}), sexp, yojson)] -type stepper_state = - | StepPending(int) - | StepperReady - | StepperDone - | StepTimeout(EvalObj.t); - -[@deriving (show({with_path: false}), sexp, yojson)] -type history = Aba.t((DHExp.t, EvaluatorState.t), step); - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = { - history, - next_options: list((FilterAction.action, EvalObj.t)), - stepper_state, -}; - -let rec matches = - ( - env: ClosureEnvironment.t, - flt: FilterEnvironment.t, - ctx: EvalCtx.t, - exp: DHExp.t, - act: FilterAction.t, - idx: int, - ) - : (FilterAction.t, int, EvalCtx.t) => { - let composed = EvalCtx.compose(ctx, exp); - let (pact, pidx) = (act, idx); - let (mact, midx) = FilterMatcher.matches(~env, ~exp=composed, ~act, flt); - let (act, idx) = - switch (ctx) { - | Term({term: Filter(_, _), _}) => (pact, pidx) - | _ => midx > pidx ? (mact, midx) : (pact, pidx) - }; - let map = ((a, i, c), f) => { - (a, i, f(c)); - }; - let (let+) = map; - let (ract, ridx, rctx) = - switch (ctx) { - | Mark => (act, idx, EvalCtx.Mark) - | Term({term, ids}) => - let rewrap = term => EvalCtx.Term({term, ids}); - switch ((term: EvalCtx.term)) { - | Closure(env, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Closure(env, ctx) |> rewrap; - | Filter(Filter(flt'), ctx) => - let flt = flt |> FilterEnvironment.extends(flt'); - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Filter(Filter(flt'), ctx) |> rewrap; - | Filter(Residue(idx', act'), ctx) => - let (ract, ridx, rctx) = - if (idx > idx') { - matches(env, flt, ctx, exp, act, idx); - } else { - matches(env, flt, ctx, exp, act', idx'); - }; - if (act' |> snd == All) { - (ract, ridx, Filter(Residue(idx', act'), rctx) |> rewrap); - } else { - (ract, ridx, rctx); - }; - | Seq1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Seq1(ctx, d2) |> rewrap; - | Seq2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Seq2(d1, ctx) |> rewrap; - | Let1(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Let1(d1, ctx, d3) |> rewrap; - | Let2(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Let2(d1, d2, ctx) |> rewrap; - | Fun(dp, ctx, env', name) => - let+ ctx = - matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); - Fun(dp, ctx, env', name) |> rewrap; - | FixF(name, ctx, env') => - let+ ctx = - matches(Option.value(~default=env, env'), flt, ctx, exp, act, idx); - FixF(name, ctx, env') |> rewrap; - | Ap1(dir, ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap1(dir, ctx, d2) |> rewrap; - | Ap2(dir, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Ap2(dir, d1, ctx) |> rewrap; - | TypAp(ctx, ty) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - TypAp(ctx, ty) |> rewrap; - | DeferredAp1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - DeferredAp1(ctx, d2) |> rewrap; - | DeferredAp2(d1, ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - DeferredAp2(d1, ctx, ds) |> rewrap; - | If1(ctx, d2, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If1(ctx, d2, d3) |> rewrap; - | If2(d1, ctx, d3) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If2(d1, ctx, d3) |> rewrap; - | If3(d1, d2, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - If3(d1, d2, ctx) |> rewrap; - | UnOp(op, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - UnOp(op, ctx) |> rewrap; - | BinOp1(op, ctx, d1) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinOp1(op, ctx, d1) |> rewrap; - | BinOp2(op, d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - BinOp2(op, d1, ctx) |> rewrap; - | Tuple(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Tuple(ctx, ds) |> rewrap; - | Test(ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Test(ctx) |> rewrap; - | ListLit(ctx, ds) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListLit(ctx, ds) |> rewrap; - | Cons1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cons1(ctx, d2) |> rewrap; - | Cons2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cons2(d1, ctx) |> rewrap; - | ListConcat1(ctx, d2) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListConcat1(ctx, d2) |> rewrap; - | ListConcat2(d1, ctx) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - ListConcat2(d1, ctx) |> rewrap; - | MultiHole(ctx, (dl, dr)) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MultiHole(ctx, (dl, dr)) |> rewrap; - | Cast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - Cast(ctx, ty, ty') |> rewrap; - | FailedCast(ctx, ty, ty') => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - FailedCast(ctx, ty, ty') |> rewrap; - | DynamicErrorHole(ctx, error) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - DynamicErrorHole(ctx, error) |> rewrap; - | MatchScrut(ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MatchScrut(ctx, rs) |> rewrap; - | MatchRule(scr, p, ctx, rs) => - let+ ctx = matches(env, flt, ctx, exp, act, idx); - MatchRule(scr, p, ctx, rs) |> rewrap; - }; - }; - switch (ctx) { - | Term({term: Filter(_), _}) => (ract, ridx, rctx) - | _ when midx > pidx && mact |> snd == All => ( - ract, - ridx, - Term({term: Filter(Residue(midx, mact), rctx), ids: [Id.mk()]}), - ) - | _ => (ract, ridx, rctx) - }; -}; - -let should_hide_eval_obj = - (~settings, x: EvalObj.t): (FilterAction.action, EvalObj.t) => - if (should_hide_step_kind(~settings, x.knd)) { - (Eval, x); - } else { - let (act, _, ctx) = - matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); - switch (act) { - | (Eval, _) => (Eval, {...x, ctx}) - | (Step, _) => (Step, {...x, ctx}) - }; - }; - -let should_hide_step = (~settings, x: step): (FilterAction.action, step) => - if (should_hide_step_kind(~settings, x.knd)) { - (Eval, x); - } else { - let (act, _, ctx) = - matches(ClosureEnvironment.empty, [], x.ctx, x.d_loc, (Step, One), 0); - switch (act) { - | (Eval, _) => (Eval, {...x, ctx}) - | (Step, _) => (Step, {...x, ctx}) - }; - }; - -let get_elab = ({history, _}: t): Elaborator.Elaboration.t => { - let (d, _) = Aba.last_a(history); - {d: d}; -}; - -let get_next_steps = s => s.next_options |> List.map(snd); - -let current_expr = ({history, _}: t) => Aba.hd(history) |> fst; - -let current_state = ({history, _}: t) => Aba.hd(history) |> snd; - -let step_pending = (idx: int, stepper: t) => { - {...stepper, stepper_state: StepPending(idx)}; -}; - -let init = (~settings, {d}: Elaborator.Elaboration.t) => { - let state = EvaluatorState.init; - { - history: Aba.singleton((d, state)), - next_options: decompose(~settings, d, state), - stepper_state: StepperReady, - }; -}; - -let rec evaluate_pending = (~settings, s: t) => { - switch (s.stepper_state) { - | StepperDone - | StepTimeout(_) => s - | StepperReady => - let next' = List.mapi((i, x) => (i, x), s.next_options); - switch ( - List.find_opt(((_, (act, _))) => act == FilterAction.Eval, next') - ) { - | Some((i, (_, _))) => - {...s, stepper_state: StepPending(i)} |> evaluate_pending(~settings) - | None => {...s, stepper_state: StepperDone} - }; - | StepPending(i) => - let (_, eo) = List.nth(s.next_options, i); - let (d, state) = Aba.hd(s.history); - let state_ref = ref(state); - let d_loc' = - ( - switch (take_step(state_ref, eo.env, eo.d_loc)) { - | Some(d) => d |> DHExp.repair_ids - | None => raise(Exception) - } - ) - |> DHExp.repair_ids; - let d' = EvalCtx.compose(eo.ctx, d_loc'); - let new_step = { - d, - d_loc: eo.d_loc, - d_loc', - ctx: eo.ctx, - knd: eo.knd, - state, - }; - let new_state = state_ref^; - { - history: s.history |> Aba.cons((d', new_state), new_step), - stepper_state: StepperReady, - next_options: decompose(~settings, d', new_state), - } - |> evaluate_pending(~settings); - }; -}; - -let rec evaluate_full = (~settings, s: t) => { - switch (s.stepper_state) { - | StepTimeout(_) => s - | StepperDone when s.next_options == [] => s - | StepperDone => s |> step_pending(0) |> evaluate_full(~settings) - | StepperReady - | StepPending(_) => - evaluate_pending(~settings, s) |> evaluate_full(~settings) - }; -}; - -let timeout = - fun - | {stepper_state: StepPending(idx), _} as s => { - ...s, - stepper_state: StepTimeout(List.nth(s.next_options, idx) |> snd), - } - | {stepper_state: StepTimeout(_) | StepperReady | StepperDone, _} as s => s; - -let rec truncate_history = (~settings) => - fun - | ([_, ...as_], [b, ...bs]) - when should_hide_step(~settings, b) |> fst == Eval => - truncate_history(~settings, (as_, bs)) - | ([_, ...as_], [_, ...bs]) => Some((as_, bs)) - | _ => None; - -let step_backward = (~settings, s: t) => { - let h' = - truncate_history(~settings, s.history) - |> Option.value(~default=s.history); - { - history: h', - next_options: - decompose(~settings, Aba.hd(h') |> fst, Aba.hd(h') |> snd), - stepper_state: StepperDone, - }; -}; - -let can_undo = (~settings, s: t) => { - truncate_history(~settings, s.history) |> Option.is_some; -}; - -let get_justification: step_kind => string = - fun - | LetBind => "substitution" - | Seq => "sequence" - | FixUnwrap => "unroll fixpoint" - | UpdateTest => "update test" - | TypFunAp => "apply type function" - | FunAp => "apply function" - | DeferredAp => "deferred application" - | BuiltinWrap => "wrap builtin" - | BuiltinAp(s) => "evaluate " ++ s - | UnOp(Int(Minus)) - | BinIntOp(Plus | Minus | Times | Power | Divide) - | BinFloatOp(Plus | Minus | Times | Power | Divide) => "arithmetic" - | BinIntOp(LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual) - | BinFloatOp(LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual) => "comparison" - | BinIntOp(Equals | NotEquals) - | BinFloatOp(Equals | NotEquals) - | BinStringOp(Equals) => "check equality" - | BinStringOp(Concat) => "string manipulation" - | UnOp(Bool(Not)) - | BinBoolOp(_) => "boolean logic" - | Conditional(_) => "conditional" - | ListCons => "list manipulation" - | ListConcat => "list manipulation" - | CaseApply => "case selection" - | Projection => "projection" // TODO(Matt): We don't want to show projection to the user - | InvalidStep => "error" - | VarLookup => "variable lookup" - | CastTypAp - | CastAp - | Cast => "cast calculus" - | FixClosure => "fixpoint closure" - | CompleteFilter => "complete filter" - | CompleteClosure => "complete closure" - | FunClosure => "function closure" - | RemoveTypeAlias => "define type" - | RemoveParens => "remove parentheses" - | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); - -type step_info = { - d: DHExp.t, - chosen_step: option(step), // The step that was taken next - hidden_steps: list((step, Id.t)), // The hidden steps between previous_step and the current one (an Id in included because it may have changed since the step was taken) - previous_step: option((step, Id.t)) // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) -}; - -let get_history = (~settings, stepper) => { - let should_skip_step = step => - step |> should_hide_step(~settings) |> fst == Eval; - let grouped_steps = - stepper.history - |> Aba.fold_right( - ((d, _), step, result) => - if (should_skip_step(step)) { - Aba.map_hd(((_, hs)) => (d, [step, ...hs]), result); - } else { - Aba.cons((d, []), step, result); - }, - ((d, _)) => Aba.singleton((d, [])), - ); - let replace_id = (x, y, (s, z)) => (s, x == z ? y : z); - let track_ids = - ( - ( - chosen_step: option(step), - (d: DHExp.t, hidden_steps: list(step)), - previous_step: option(step), - ), - ) => { - let (previous_step, hidden_steps) = - List.fold_left( - ((ps, hs), h: step) => { - let replacement = - replace_id(h.d_loc |> DHExp.rep_id, h.d_loc' |> DHExp.rep_id); - ( - Option.map(replacement, ps), - [(h, h.d_loc' |> DHExp.rep_id), ...List.map(replacement, hs)], - ); - }, - (Option.map(x => (x, x.d_loc' |> DHExp.rep_id), previous_step), []), - hidden_steps, - ); - {d, previous_step, hidden_steps, chosen_step}; - }; - let padded = grouped_steps |> Aba.bab_triples; - let result = padded |> List.map(track_ids); - result; - //grouped_steps |> Aba.bab_triples |> List.map(track_ids); -}; - -let hidden_steps_of_info = (info: step_info): list(step_info) => { - // note the previous_step field is fudged because it is currently usused.next_options - List.map( - ((hs: step, _)) => - { - d: hs.d, - chosen_step: Some(hs), - hidden_steps: [], - previous_step: None, - }, - info.hidden_steps, - ); -}; - -[@deriving (show({with_path: false}), sexp, yojson)] -type persistent = {history}; - -let (sexp_of_persistent, persistent_of_sexp) = - StructureShareSexp.structure_share_in( - sexp_of_persistent, - persistent_of_sexp, - ); - -let (sexp_of_persistent, persistent_of_sexp) = - StructureShareSexp.structure_share_in( - sexp_of_persistent, - persistent_of_sexp, - ); - -// Remove EvalObj.t objects from stepper to prevent problems when loading -let to_persistent: t => persistent = ({history, _}) => {history: history}; - -let from_persistent = (~settings, {history}) => { - { - history, - next_options: - decompose(~settings, Aba.hd(history) |> fst, Aba.hd(history) |> snd), - stepper_state: StepperDone, - }; -}; diff --git a/src/haz3lcore/dynamics/Transition.re b/src/haz3lcore/dynamics/Transition.re index 5c936426b9..c178a49dfa 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -817,3 +817,43 @@ let should_hide_step_kind = (~settings: CoreSettings.Evaluation.t) => | FunClosure | FixClosure | RemoveParens => true; + +let stepper_justification: step_kind => string = + fun + | LetBind => "substitution" + | Seq => "sequence" + | FixUnwrap => "unroll fixpoint" + | UpdateTest => "update test" + | TypFunAp => "apply type function" + | FunAp => "apply function" + | DeferredAp => "deferred application" + | BuiltinWrap => "wrap builtin" + | BuiltinAp(s) => "evaluate " ++ s + | UnOp(Int(Minus)) + | BinIntOp(Plus | Minus | Times | Power | Divide) + | BinFloatOp(Plus | Minus | Times | Power | Divide) => "arithmetic" + | BinIntOp(LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual) + | BinFloatOp(LessThan | LessThanOrEqual | GreaterThan | GreaterThanOrEqual) => "comparison" + | BinIntOp(Equals | NotEquals) + | BinFloatOp(Equals | NotEquals) + | BinStringOp(Equals) => "check equality" + | BinStringOp(Concat) => "string manipulation" + | UnOp(Bool(Not)) + | BinBoolOp(_) => "boolean logic" + | Conditional(_) => "conditional" + | ListCons => "list manipulation" + | ListConcat => "list manipulation" + | CaseApply => "case selection" + | Projection => "projection" // TODO(Matt): We don't want to show projection to the user + | InvalidStep => "error" + | VarLookup => "variable lookup" + | CastTypAp + | CastAp + | Cast => "cast calculus" + | FixClosure => "fixpoint closure" + | CompleteFilter => "complete filter" + | CompleteClosure => "complete closure" + | FunClosure => "function closure" + | RemoveTypeAlias => "define type" + | RemoveParens => "remove parentheses" + | UnOp(Meta(Unquote)) => failwith("INVALID STEP"); diff --git a/src/haz3lcore/lang/Form.re b/src/haz3lcore/lang/Form.re index 1990461239..5ab6368cc8 100644 --- a/src/haz3lcore/lang/Form.re +++ b/src/haz3lcore/lang/Form.re @@ -246,7 +246,6 @@ let atomic_forms: list((string, (string => bool, list(Mold.t)))) = [ let forms: list((string, t)) = [ // INFIX OPERATORS - ("typ_plus", mk_infix("+", Typ, P.type_plus)), ("type-arrow", mk_infix("->", Typ, P.type_arrow)), ("cell-join", mk_infix(";", Exp, P.semi)), ("plus", mk_infix("+", Exp, P.plus)), @@ -279,7 +278,9 @@ let forms: list((string, t)) = [ ("list_concat", mk_infix("@", Exp, P.plus)), ("cons_exp", mk_infix("::", Exp, P.cons)), ("cons_pat", mk_infix("::", Pat, P.cons)), - ("typeann", mk(ss, [":"], mk_bin'(P.ann, Pat, Pat, [], Typ))), + ("typeann", mk(ss, [":"], mk_bin'(P.cast, Pat, Pat, [], Typ))), + ("typeasc", mk(ss, [":"], mk_bin'(P.cast, Exp, Exp, [], Typ))), + ("typ_plus", mk_infix("+", Typ, P.type_plus)), // UNARY PREFIX OPERATORS ("not", mk(ii, ["!"], mk_pre(P.not_, Exp, []))), ("typ_sum_single", mk(ss, ["+"], mk_pre(P.or_, Typ, []))), @@ -300,7 +301,7 @@ let forms: list((string, t)) = [ ("ap_exp_empty", mk(ii, ["()"], mk_post(P.ap, Exp, []))), ("ap_exp", mk(ii, ["(", ")"], mk_post(P.ap, Exp, [Exp]))), ("ap_pat", mk(ii, ["(", ")"], mk_post(P.ap, Pat, [Pat]))), - ("ap_typ", mk(ii, ["(", ")"], mk_post(P.ap, Typ, [Typ]))), + ("ap_typ", mk(ii, ["(", ")"], mk_post(P.type_sum_ap, Typ, [Typ]))), ( "ap_exp_typ", mk((Instant, Static), ["@<", ">"], mk_post(P.ap, Exp, [Typ])), @@ -333,7 +334,7 @@ let forms: list((string, t)) = [ ]; let get: String.t => t = - name => Util.ListUtil.assoc_err(name, forms, "Forms.get"); + name => Util.ListUtil.assoc_err(name, forms, "Forms.get : " ++ name); let delims: list(Token.t) = forms diff --git a/src/haz3lcore/lang/Operators.re b/src/haz3lcore/lang/Operators.re index aa8842b72b..5ec740e2cc 100644 --- a/src/haz3lcore/lang/Operators.re +++ b/src/haz3lcore/lang/Operators.re @@ -175,3 +175,12 @@ let string_op_to_string = (op: op_bin_string): string => { | Equals => "$==" }; }; + +let bin_op_to_string = (op: op_bin): string => { + switch (op) { + | Int(op) => int_op_to_string(op) + | Float(op) => float_op_to_string(op) + | Bool(op) => bool_op_to_string(op) + | String(op) => string_op_to_string(op) + }; +}; diff --git a/src/haz3lcore/lang/Precedence.re b/src/haz3lcore/lang/Precedence.re index 7d72b66404..3a5b54ec5b 100644 --- a/src/haz3lcore/lang/Precedence.re +++ b/src/haz3lcore/lang/Precedence.re @@ -2,60 +2,145 @@ open Util; /** * higher precedence means lower int representation + * + * These precedences are interspersed with examples to help you + * work out the precedence. For each example, if a construct + * requires parentheses when placed in the '_____' space, then + * your new construct's precedence is below the comment with + * the example. (i.e. higher int) */ [@deriving (show({with_path: false}), sexp, yojson)] type t = int; +let associativity_map: ref(list((t, Direction.t))) = ref([]); +let left_associative = (level: t) => { + associativity_map := [(level, Direction.Left), ...associativity_map^]; + level; +}; +let right_associative = (level: t) => { + associativity_map := [(level, Direction.Right), ...associativity_map^]; + level; +}; + let max: t = 0; -let unquote = 1; -let ap = 2; -let neg = 3; -let power = 4; -let mult = 5; -let not_ = 5; -let plus = 6; -let cons = 7; -let concat = 8; -let eqs = 9; -let and_ = 10; -let or_ = 11; -let ann = 12; -let if_ = 13; -let fun_ = 14; -let semi = 16; -let let_ = 17; -let filter = 18; -let rule_arr = 19; -let rule_pre = 20; -let rule_sep = 21; -let case_ = 22; - -let comma = 15; - -let type_plus = 4; -let type_arrow = 5; -let type_prod = comma; - -let min = 26; +// ========== TYPES ========== +let type_sum_ap = 11; +// _____ (Int) +// + T1 + _____ +let type_plus = 12 |> right_associative; +// _____ -> Int +let type_arrow = 13 |> right_associative; +// Int -> _____ +// String , _____ , String +let type_prod = 14; +let type_binder = 15; +// forall t -> _____ +// rec t -> _____ + +// ======== PATTERNS ========= +// ======= EXPRESSIONS ======= + +let unquote = 21; +// $_____ +let ap = 22; +// _____(x) +// 5 : _____ +let cast = 23 |> left_associative; +// _____ : T +// - _____ +let neg = 24; +// _____ ** 2 +let power = 25 |> right_associative; +// 2 ** _____ +// 6 / _____ +let mult = 26 |> left_associative; +let not_ = 26; +// _____ / 6 +// 4 - _____ +let plus = 27 |> left_associative; +// _____ - 4 +// _____ :: [] +let cons = 28 |> right_associative; +// 1 :: _____ +// [1,2] @ _____ +let concat = 29 |> right_associative; +// _____ @ [1,2] +// x == _____ +let eqs = 30 |> left_associative; +// _____ == x +// _____ && true +let and_ = 31; +// true && _____ +// _____ || false +let or_ = 32; +// false || _____ +let if_ = 34; +let fun_ = 35; +// fun x -> _____ +let prod = 36; +// a , _____ , x +// _____ ; () +let semi = 37 |> right_associative; +// () ; _____ +let let_ = 38; +// let x = 3 in _____ +let rule_arr = 39; +let rule_pre = 40; +let rule_sep = 41; +let case_ = 42; + +let comma = 45; + +let min = 46; let compare = (p1: t, p2: t): int => (-1) * Int.compare((p1 :> int), (p2 :> int)); // let min = (p1: t, p2: t): t => max(p1, p2); let associativity_map: IntMap.t(Direction.t) = - [ - (mult, Direction.Left), - (plus, Left), - (power, Right), - (cons, Right), - (concat, Right), - (ann, Left), - (eqs, Left), - (type_arrow, Right), - ] - |> List.to_seq - |> IntMap.of_seq; + associativity_map^ |> List.to_seq |> IntMap.of_seq; let associativity = (p: t): option(Direction.t) => IntMap.find_opt(p, associativity_map); + +let of_bin_op: Operators.op_bin => t = + fun + | Int(op) => + switch (op) { + | Plus => plus + | Minus => plus + | Times => mult + | Power => power + | Divide => mult + | LessThan => eqs + | LessThanOrEqual => eqs + | GreaterThan => eqs + | GreaterThanOrEqual => eqs + | Equals => eqs + | NotEquals => eqs + } + | Float(op) => + switch (op) { + | Plus => plus + | Minus => plus + | Times => mult + | Power => power + | Divide => mult + | LessThan => eqs + | LessThanOrEqual => eqs + | GreaterThan => eqs + | GreaterThanOrEqual => eqs + | Equals => eqs + | NotEquals => eqs + } + | Bool(op) => + switch (op) { + | And => and_ + | Or => or_ + } + | String(op) => + switch (op) { + | Concat => concat + | Equals => eqs + }; diff --git a/src/haz3lcore/lang/term/IdTagged.re b/src/haz3lcore/lang/term/IdTagged.re index 3812b0e83f..200be8a4ab 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -22,6 +22,9 @@ type t('a) = { let fresh = term => { {ids: [Id.mk()], copied: false, term}; }; +let fresh_deterministic = (prev_id, term) => { + {ids: [Id.next(prev_id)], copied: false, term}; +}; let term_of = x => x.term; let unwrap = x => (x.term, term' => {...x, term: term'}); diff --git a/src/haz3lcore/lang/term/Typ.re b/src/haz3lcore/lang/term/Typ.re index c9a6f0c204..0647ef1865 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -34,6 +34,29 @@ let fresh: term => t = IdTagged.fresh; let temp: term => t = term => {term, ids: [Id.invalid], copied: false}; let rep_id: t => Id.t = IdTagged.rep_id; +let all_ids_temp = { + let f: + 'a. + (IdTagged.t('a) => IdTagged.t('a), IdTagged.t('a)) => IdTagged.t('a) + = + (continue, exp) => {...exp, ids: [Id.invalid]} |> continue; + map_term(~f_exp=f, ~f_pat=f, ~f_typ=f, ~f_tpat=f, ~f_rul=f); +}; + +let (replace_temp, replace_temp_exp) = { + let f: + 'a. + (IdTagged.t('a) => IdTagged.t('a), IdTagged.t('a)) => IdTagged.t('a) + = + (continue, exp) => + {...exp, ids: exp.ids == [Id.invalid] ? [Id.mk()] : exp.ids} + |> continue; + ( + map_term(~f_exp=f, ~f_pat=f, ~f_typ=f, ~f_tpat=f, ~f_rul=f), + TermBase.Exp.map_term(~f_exp=f, ~f_pat=f, ~f_typ=f, ~f_tpat=f, ~f_rul=f), + ); +}; + let hole = (tms: list(TermBase.Any.t)): TermBase.Typ.term => switch (tms) { | [] => Unknown(Hole(EmptyHole)) diff --git a/src/haz3lcore/pretty/ExpToSegment.re b/src/haz3lcore/pretty/ExpToSegment.re new file mode 100644 index 0000000000..c2f57d0229 --- /dev/null +++ b/src/haz3lcore/pretty/ExpToSegment.re @@ -0,0 +1,1138 @@ +open Util; +open PrettySegment; +open Base; + +module Settings = { + type t = { + inline: bool, + fold_case_clauses: bool, + fold_fn_bodies: bool, + hide_fixpoints: bool, + fold_cast_types: bool, + }; + + let of_core = (~inline, settings: CoreSettings.t) => { + inline, + fold_case_clauses: !settings.evaluation.show_case_clauses, + fold_fn_bodies: !settings.evaluation.show_fn_bodies, + hide_fixpoints: !settings.evaluation.show_fixpoints, + fold_cast_types: !settings.evaluation.show_casts, + }; +}; + +let should_add_space = (s1, s2) => + switch () { + | _ when String.ends_with(s1, ~suffix="(") => false + | _ when String.ends_with(s1, ~suffix="[") => false + | _ when String.starts_with(s2, ~prefix=")") => false + | _ when String.starts_with(s2, ~prefix="]") => false + | _ when String.starts_with(s2, ~prefix=",") => false + | _ when String.starts_with(s2, ~prefix=";") => false + | _ when String.starts_with(s2, ~prefix=":") => false + | _ when String.ends_with(s1, ~suffix=" ") => false + | _ when String.starts_with(s2, ~prefix=" ") => false + | _ when String.ends_with(s1, ~suffix="\n") => false + | _ when String.starts_with(s2, ~prefix="\n") => false + | _ + when + String.ends_with(s1, ~suffix="PROJECTOR") + && String.starts_with(s2, ~prefix="(") => + false + | _ + when + String.ends_with(s1, ~suffix=")") + && String.starts_with(s2, ~prefix="(") => + false + | _ + when + Form.is_potential_operand(s1) + && !Form.is_keyword(s1) + && String.starts_with(s2, ~prefix="(") => + false + | _ => true + }; + +let text_to_pretty = (id, sort, str): pretty => { + p_just([ + Tile({ + id, + label: [str], + mold: Mold.mk_op(sort, []), + shards: [0], + children: [], + }), + ]); +}; + +let mk_form = (form_name: string, id, children): Piece.t => { + let form: Form.t = Form.get(form_name); + assert(List.length(children) == List.length(form.mold.in_)); + // Add whitespaces + let children = + Aba.map_abas( + ((l, child, r)) => { + let lspace = should_add_space(l, child |> Segment.first_string); + let rspace = should_add_space(child |> Segment.last_string, r); + (lspace ? [Secondary(Secondary.mk_space(Id.mk()))] : []) + @ ( + rspace ? child @ [Secondary(Secondary.mk_space(Id.mk()))] : child + ); + }, + Aba.mk(form.label, children), + ) + |> Aba.get_bs; + Tile({ + id, + label: form.label, + mold: form.mold, + shards: List.init(List.length(children) + 1, n => n), + children, + }); +}; + +/* HACK[Matt]: Sometimes terms that should have multiple ids won't because + evaluation only ever gives them one */ +let pad_ids = (n: int, ids: list(Id.t)): list(Id.t) => { + let len = List.length(ids); + if (len < n) { + ids @ List.init(n - len, _ => Id.mk()); + } else { + ListUtil.split_n(n, ids) |> fst; + }; +}; + +let (@) = (seg1: Segment.t, seg2: Segment.t): Segment.t => + switch (seg1, seg2) { + | ([], _) => seg2 + | (_, []) => seg1 + | _ => + if (should_add_space( + Segment.last_string(seg1), + Segment.first_string(seg2), + )) { + seg1 @ [Secondary(Secondary.mk_space(Id.mk()))] @ seg2; + } else { + seg1 @ seg2; + } + }; + +let fold_if = (condition, pieces) => + if (condition) { + [ + ProjectorPerform.Update.init( + Fold, + mk_form("parens_exp", Id.mk(), [pieces]), + ), + ]; + } else { + pieces; + }; + +let fold_fun_if = (condition, f_name: string, pieces) => + if (condition) { + [ + ProjectorPerform.Update.init_from_str( + Fold, + mk_form("parens_exp", Id.mk(), [pieces]), + ({text: f_name}: FoldProj.t) + |> FoldProj.sexp_of_t + |> Sexplib.Sexp.to_string, + ), + ]; + } else { + pieces; + }; + +/* We assume that parentheses have already been added as necessary, and + that the expression has no DynamicErrorHoles, Casts, or FailedCasts + */ +let rec exp_to_pretty = (~settings: Settings.t, exp: Exp.t): pretty => { + let exp = Exp.substitute_closures(Environment.empty, exp); + let go = (~inline=settings.inline) => + exp_to_pretty(~settings={...settings, inline}); + switch (exp |> Exp.term_of) { + // Assume these have been removed by the parenthesizer + | DynamicErrorHole(_) + | Filter(_) => failwith("printing these not implemented yet") + // Forms which should be removed by substitute_closures + | Closure(_) => failwith("closure not removed before printing") + // Other cases + | Invalid(x) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, x) + | EmptyHole => + let id = exp |> Exp.rep_id; + p_just([Grout({id, shape: Convex})]); + | Undefined => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, "undefined") + | Bool(b) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, Bool.to_string(b)) + | Int(n) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, Int.to_string(n)) + // TODO: do floats print right? + | Float(f) => + text_to_pretty(exp |> Exp.rep_id, Sort.Exp, Float.to_string(f)) + | String(s) => + text_to_pretty(exp |> Exp.rep_id, Sort.Exp, "\"" ++ s ++ "\"") + // TODO: Make sure types are correct + | Constructor(c, _t) => + // let id = Id.mk(); + let+ e = text_to_pretty(exp |> Exp.rep_id, Sort.Exp, c); + // and+ t = typ_to_pretty(~settings: Settings.t, t); + e; + // @ [mk_form("typeasc", id, [])] + // @ (t |> fold_if(settings.fold_cast_types)); + | ListLit([]) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, "[]") + | Deferral(_) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, "deferral") + | ListLit([x, ...xs]) => + // TODO: Add optional newlines + let* x = go(x) + and* xs = xs |> List.map(go) |> all; + let (id, ids) = ( + exp.ids |> List.hd, + exp.ids |> List.tl |> pad_ids(List.length(xs)), + ); + let form = (x, xs) => + mk_form( + "list_lit_exp", + id, + [ + x + @ List.flatten( + List.map2( + (id, x) => [mk_form("comma_exp", id, [])] @ x, + ids, + xs, + ), + ), + ], + ); + p_just([form(x, xs)]); + | Var(v) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, v) + | BinOp(op, l, r) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ l = go(l) + and+ r = go(r); + l + @ [ + Tile({ + id, + label: [Operators.bin_op_to_string(op)], + mold: Mold.mk_bin(Precedence.of_bin_op(op), Sort.Exp, []), + shards: [0], + children: [], + }), + ] + @ r; + | MultiHole(es) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ es = es |> List.map(any_to_pretty(~settings)) |> all; + ListUtil.flat_intersperse(Grout({id, shape: Concave}), es); + | Parens({term: Fun(p, e, _, _), _} as inner_exp) => + // TODO: Add optional newlines + let id = inner_exp |> Exp.rep_id; + let+ p = pat_to_pretty(~settings: Settings.t, p) + and+ e = go(e); + let name = Exp.get_fn_name(exp) |> Option.value(~default="anon fun"); + let name = + if (settings.hide_fixpoints && String.ends_with(~suffix="+", name)) { + String.sub(name, 0, String.length(name) - 1); + } else { + name; + }; + let name = "<" ++ name ++ ">"; + let fun_form = [mk_form("fun_", id, [p])] @ e; + [mk_form("parens_exp", exp |> Exp.rep_id, [fun_form])] + |> fold_fun_if(settings.fold_fn_bodies, name); + | Fun(p, e, _, _) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ p = pat_to_pretty(~settings: Settings.t, p) + and+ e = go(e); + let name = Exp.get_fn_name(exp) |> Option.value(~default="anon fun"); + let name = + if (settings.hide_fixpoints && String.ends_with(~suffix="+", name)) { + String.sub(name, 0, String.length(name) - 1); + } else { + name; + }; + let name = "<" ++ name ++ ">"; + [mk_form("fun_", id, [p])] + @ e + |> fold_fun_if(settings.fold_fn_bodies, name); + | TypFun(tp, e, _) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ tp = tpat_to_pretty(~settings: Settings.t, tp) + and+ e = go(e); + let name = + "<" + ++ (Exp.get_fn_name(exp) |> Option.value(~default="anon typfun")) + ++ ">"; + [mk_form("typfun", id, [tp])] + @ e + |> fold_fun_if(settings.fold_fn_bodies, name); + | Tuple([]) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, "()") + | Tuple([_]) => failwith("Singleton Tuples are not allowed") + | Tuple([x, ...xs]) => + // TODO: Add optional newlines + let+ x = go(x) + and+ xs = xs |> List.map(go) |> all; + let ids = exp.ids |> pad_ids(List.length(xs)); + x + @ List.flatten( + List.map2((id, x) => [mk_form("comma_exp", id, [])] @ x, ids, xs), + ); + | Let(p, e1, e2) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + // This step undoes the adding of fixpoints that happens in elaboration. + let e1 = settings.hide_fixpoints ? Exp.unfix(e1, p) : e1; + let+ p = pat_to_pretty(~settings: Settings.t, p) + and+ e1 = go(e1) + and+ e2 = go(e2); + let e2 = + settings.inline + ? e2 : [Secondary(Secondary.mk_newline(Id.mk()))] @ e2; + [mk_form("let_", id, [p, e1])] @ e2; + | FixF(p, e, _) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ p = pat_to_pretty(~settings: Settings.t, p) + and+ e = go(e); + let name = + "<" ++ (Exp.get_fn_name(exp) |> Option.value(~default="fun")) ++ ">"; + [mk_form("fix", id, [p])] + @ e + |> fold_fun_if(settings.fold_fn_bodies, name); + | TyAlias(tp, t, e) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ tp = tpat_to_pretty(~settings: Settings.t, tp) + and+ t = typ_to_pretty(~settings: Settings.t, t) + and+ e = go(e); + let e = + settings.inline ? e : [Secondary(Secondary.mk_newline(Id.mk()))] @ e; + [mk_form("type_alias", id, [tp, t])] @ e; + | Ap(Forward, e1, e2) => + let id = exp |> Exp.rep_id; + let+ e1 = go(e1) + and+ e2 = go(e2); + e1 @ [mk_form("ap_exp", id, [e2])]; + | Ap(Reverse, e1, e2) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ e1 = go(e1) + and+ e2 = go(e2) + and+ op = text_to_pretty(id, Sort.Exp, "|>"); + e2 @ op @ e1; + | TypAp(e, t) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ e = go(e) + and+ tp = typ_to_pretty(~settings: Settings.t, t); + e @ [mk_form("ap_exp_typ", id, [tp])]; + | DeferredAp(e, es) => + // TODO: Add optional newlines + let+ e = go(e) + and+ es = es |> List.map(go) |> all; + let (id, ids) = ( + exp.ids |> List.hd, + exp.ids |> List.tl |> pad_ids(List.length(es)), + ); + e + @ [ + mk_form( + "ap_exp", + id, + [ + (es |> List.hd) + @ List.flatten( + List.map2( + (id, e) => [mk_form("comma_exp", id, [])] @ e, + ids |> List.tl, + es |> List.tl, + ), + ), + ], + ), + ]; + | If(e1, e2, e3) => + let id = exp |> Exp.rep_id; + let+ e1 = go(e1) + and+ e2 = go(e2) + and+ e3 = go(e3); + let e2 = + settings.inline + ? e2 + : [Secondary(Secondary.mk_newline(Id.mk()))] + @ e2 + @ [Secondary(Secondary.mk_newline(Id.mk()))]; + let e3 = + settings.inline + ? e3 : [Secondary(Secondary.mk_newline(Id.mk()))] @ e3; + [mk_form("if_", id, [e1, e2])] @ e3; + | Seq(e1, e2) => + // TODO: Make newline optional + let id = exp |> Exp.rep_id; + let+ e1 = go(e1) + and+ e2 = go(e2); + let e2 = + settings.inline + ? e2 : [Secondary(Secondary.mk_newline(Id.mk()))] @ e2; + e1 @ [mk_form("cell-join", id, [])] @ e2; + | Test(e) => + let id = exp |> Exp.rep_id; + let+ e = go(e); + [mk_form("test", id, [e])]; + | Parens(e) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ e = go(e); + [mk_form("parens_exp", id, [e])]; + | Cons(e1, e2) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ e1 = go(e1) + and+ e2 = go(e2); + e1 @ [mk_form("cons_exp", id, [])] @ e2; + | ListConcat(e1, e2) => + // TODO: Add optional newlines + let id = exp |> Exp.rep_id; + let+ e1 = go(e1) + and+ e2 = go(e2); + e1 @ [mk_form("list_concat", id, [])] @ e2; + | UnOp(Meta(Unquote), e) => + let id = exp |> Exp.rep_id; + let+ e = go(e); + [mk_form("unquote", id, [])] @ e; + | UnOp(Bool(Not), e) => + let id = exp |> Exp.rep_id; + let+ e = go(e); + [mk_form("not", id, [])] @ e; + | UnOp(Int(Minus), e) => + let id = exp |> Exp.rep_id; + let+ e = go(e); + [mk_form("unary_minus", id, [])] @ e; + /* TODO: this isn't actually correct because we could the builtin + could have been overriden in this scope; worth fixing when we fix + closures. */ + | BuiltinFun(f) => text_to_pretty(exp |> Exp.rep_id, Sort.Exp, f) + | FailedCast(e, _, t) + | Cast(e, _, t) => + let id = exp |> Exp.rep_id; + let+ e = go(e) + and+ t = typ_to_pretty(~settings: Settings.t, t); + e @ [mk_form("typeasc", id, [])] @ t; + | Match(e, rs) => + // TODO: Add newlines + let+ e = go(e) + and+ rs: list((Segment.t, Segment.t)) = { + rs + |> List.map(((p, e)) => + (pat_to_pretty(~settings: Settings.t, p), go(e)) + ) + |> List.map(((x, y)) => (x, y)) + |> all; + }; + let (id, ids) = ( + exp.ids |> List.hd, + exp.ids |> List.tl |> pad_ids(List.length(rs)), + ); + [ + mk_form( + "case", + id, + [ + e + @ ( + List.map2( + (id, (p, e)) => + settings.inline + ? [] + : [Secondary(Secondary.mk_newline(Id.mk()))] + @ [mk_form("rule", id, [p])] + @ (e |> fold_if(settings.fold_case_clauses)), + ids, + rs, + ) + |> List.flatten + ) + @ ( + settings.inline + ? [] : [Secondary(Secondary.mk_newline(Id.mk()))] + ), + ], + ), + ]; + }; +} +and pat_to_pretty = (~settings: Settings.t, pat: Pat.t): pretty => { + let go = pat_to_pretty(~settings: Settings.t); + switch (pat |> Pat.term_of) { + | Invalid(t) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, t) + | EmptyHole => + let id = pat |> Pat.rep_id; + p_just([Grout({id, shape: Convex})]); + | Wild => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, "_") + | Var(v) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, v) + | Int(n) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, Int.to_string(n)) + | Float(f) => + text_to_pretty(pat |> Pat.rep_id, Sort.Pat, Float.to_string(f)) + | Bool(b) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, Bool.to_string(b)) + | String(s) => + text_to_pretty(pat |> Pat.rep_id, Sort.Pat, "\"" ++ s ++ "\"") + | Constructor(c, _) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, c) + | ListLit([]) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, "[]") + | ListLit([x, ...xs]) => + let* x = go(x) + and* xs = xs |> List.map(go) |> all; + let (id, ids) = ( + pat.ids |> List.hd, + pat.ids |> List.tl |> pad_ids(List.length(xs)), + ); + p_just([ + mk_form( + "list_lit_pat", + id, + [ + x + @ List.flatten( + List.map2( + (id, x) => [mk_form("comma_pat", id, [])] @ x, + ids, + xs, + ), + ), + ], + ), + ]); + | Cons(p1, p2) => + let id = pat |> Pat.rep_id; + let+ p1 = go(p1) + and+ p2 = go(p2); + p1 @ [mk_form("cons_pat", id, [])] @ p2; + | Tuple([]) => text_to_pretty(pat |> Pat.rep_id, Sort.Pat, "()") + | Tuple([_]) => failwith("Singleton Tuples are not allowed") + | Tuple([x, ...xs]) => + let+ x = go(x) + and+ xs = xs |> List.map(go) |> all; + let ids = pat.ids |> pad_ids(List.length(xs)); + x + @ List.flatten( + List.map2((id, x) => [mk_form("comma_pat", id, [])] @ x, ids, xs), + ); + | Parens(p) => + let id = pat |> Pat.rep_id; + let+ p = go(p); + [mk_form("parens_pat", id, [p])]; + | MultiHole(es) => + let id = pat |> Pat.rep_id; + let+ es = es |> List.map(any_to_pretty(~settings: Settings.t)) |> all; + ListUtil.flat_intersperse(Grout({id, shape: Concave}), es); + | Ap(p1, p2) => + let id = pat |> Pat.rep_id; + let+ p1 = go(p1) + and+ p2 = go(p2); + p1 @ [mk_form("ap_pat", id, [p2])]; + | Cast(p, t, _) => + let id = pat |> Pat.rep_id; + let+ p = go(p) + and+ t = typ_to_pretty(~settings: Settings.t, t); + p @ [mk_form("typeann", id, [])] @ t; + }; +} +and typ_to_pretty = (~settings: Settings.t, typ: Typ.t): pretty => { + let go = typ_to_pretty(~settings: Settings.t); + let go_constructor: ConstructorMap.variant(Typ.t) => pretty = + fun + | Variant(c, ids, None) => text_to_pretty(List.hd(ids), Sort.Typ, c) + | Variant(c, ids, Some(x)) => { + let+ constructor = + text_to_pretty(List.hd(List.tl(ids)), Sort.Typ, c); + constructor @ [mk_form("ap_typ", List.hd(ids), [go(x)])]; + } + | BadEntry(x) => go(x); + switch (typ |> Typ.term_of) { + | Unknown(Hole(Invalid(s))) => + text_to_pretty(typ |> Typ.rep_id, Sort.Typ, s) + | Unknown(Internal) + | Unknown(SynSwitch) + | Unknown(Hole(EmptyHole)) => + let id = typ |> Typ.rep_id; + p_just([Grout({id, shape: Convex})]); + | Unknown(Hole(MultiHole(es))) => + let id = typ |> Typ.rep_id; + let+ es = es |> List.map(any_to_pretty(~settings: Settings.t)) |> all; + ListUtil.flat_intersperse(Grout({id, shape: Concave}), es); + | Var(v) => text_to_pretty(typ |> Typ.rep_id, Sort.Typ, v) + | Int => text_to_pretty(typ |> Typ.rep_id, Sort.Typ, "Int") + | Float => text_to_pretty(typ |> Typ.rep_id, Sort.Typ, "Float") + | Bool => text_to_pretty(typ |> Typ.rep_id, Sort.Typ, "Bool") + | String => text_to_pretty(typ |> Typ.rep_id, Sort.Typ, "String") + | List(t) => + let id = typ |> Typ.rep_id; + let+ t = go(t); + [mk_form("list_typ", id, [t])]; + | Prod([]) => text_to_pretty(typ |> Typ.rep_id, Sort.Typ, "()") + | Prod([_]) => failwith("Singleton Prods are not allowed") + | Prod([t, ...ts]) => + let+ t = go(t) + and+ ts = ts |> List.map(go) |> all; + t + @ List.flatten( + List.map2( + (id, t) => [mk_form("comma_typ", id, [])] @ t, + typ.ids |> pad_ids(ts |> List.length), + ts, + ), + ); + | Parens(t) => + let id = typ |> Typ.rep_id; + let+ t = go(t); + [mk_form("parens_typ", id, [t])]; + | Ap(t1, t2) => + let id = typ |> Typ.rep_id; + let+ t1 = go(t1) + and+ t2 = go(t2); + t1 @ [mk_form("ap_typ", id, [t2])]; + | Rec(tp, t) => + let id = typ |> Typ.rep_id; + let+ tp = tpat_to_pretty(~settings: Settings.t, tp) + and+ t = go(t); + [mk_form("rec", id, [tp])] @ t; + | Forall(tp, t) => + let id = typ |> Typ.rep_id; + let+ tp = tpat_to_pretty(~settings: Settings.t, tp) + and+ t = go(t); + [mk_form("forall", id, [tp])] @ t; + | Arrow(t1, t2) => + let id = typ |> Typ.rep_id; + let+ t1 = go(t1) + and+ t2 = go(t2); + t1 @ [mk_form("type-arrow", id, [])] @ t2; + | Sum([]) => failwith("Empty Sums are not allowed") + | Sum([t]) => + let id = typ |> Typ.rep_id; + let+ t = go_constructor(t); + [mk_form("typ_sum_single", id, [])] @ t; + | Sum([t, ...ts]) => + let ids = typ.ids |> pad_ids(List.length(ts) + 1); + let id = List.hd(ids); + let ids = List.tl(ids); + let+ t = go_constructor(t) + and+ ts = ts |> List.map(go_constructor) |> all; + [mk_form("typ_sum_single", id, [])] + @ t + @ List.flatten( + List.map2((id, t) => [mk_form("typ_plus", id, [])] @ t, ids, ts), + ); + }; +} +and tpat_to_pretty = (~settings: Settings.t, tpat: TPat.t): pretty => { + switch (tpat |> IdTagged.term_of) { + | Invalid(t) => text_to_pretty(tpat |> TPat.rep_id, Sort.Typ, t) + | EmptyHole => + let id = tpat |> TPat.rep_id; + p_just([Grout({id, shape: Convex})]); + | MultiHole(xs) => + let id = tpat |> TPat.rep_id; + let+ xs = xs |> List.map(any_to_pretty(~settings: Settings.t)) |> all; + ListUtil.flat_intersperse(Grout({id, shape: Concave}), xs); + | Var(v) => text_to_pretty(tpat |> TPat.rep_id, Sort.Typ, v) + }; +} +and any_to_pretty = (~settings: Settings.t, any: Any.t): pretty => { + switch (any) { + | Exp(e) => exp_to_pretty(~settings: Settings.t, e) + | Pat(p) => pat_to_pretty(~settings: Settings.t, p) + | Typ(t) => typ_to_pretty(~settings: Settings.t, t) + | TPat(tp) => tpat_to_pretty(~settings: Settings.t, tp) + | Any(_) + | Nul(_) + | Rul(_) => + //TODO: print out invalid rules properly + let id = any |> Any.rep_id; + p_just([Grout({id, shape: Convex})]); + }; +}; + +// Use Precedence.re to work out where your construct goes here. +let rec external_precedence = (exp: Exp.t): Precedence.t => { + switch (Exp.term_of(exp)) { + // Forms which we are about to strip, so we just look inside + | Closure(_, x) + | DynamicErrorHole(x, _) => external_precedence(x) + + // Binary operations are handled in Precedence.re + | BinOp(op, _, _) => Precedence.of_bin_op(op) + + // Indivisible forms never need parentheses around them + | Var(_) + | Invalid(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | EmptyHole + | Deferral(_) + | BuiltinFun(_) + | Undefined => Precedence.max + + // Same goes for forms which are already surrounded + | Parens(_) + | ListLit(_) + | Test(_) + | Match(_) => Precedence.max + + // Other forms + | UnOp(Meta(Unquote), _) => Precedence.unquote + | Constructor(_) // Constructor is here because we currently always add a type annotation to constructors + | Cast(_) + | FailedCast(_) => Precedence.cast + | Ap(Forward, _, _) + | DeferredAp(_) + | TypAp(_) => Precedence.ap + | UnOp(Bool(Not), _) => Precedence.not_ + | UnOp(Int(Minus), _) => Precedence.neg + | Cons(_) => Precedence.cons + | Ap(Reverse, _, _) => Precedence.eqs + | ListConcat(_) => Precedence.concat + | If(_) => Precedence.if_ + | TypFun(_) + | Fun(_) + | FixF(_) => Precedence.fun_ + | Tuple(_) => Precedence.prod + | Seq(_) => Precedence.semi + + // Top-level things + | Filter(_) + | TyAlias(_) + | Let(_) => Precedence.let_ + + // Matt: I think multiholes are min because we don't know the precedence of the `⟩?⟨`s + | MultiHole(_) => Precedence.min + }; +}; + +let external_precedence_pat = (dp: Pat.t) => + switch (DHPat.term_of(dp)) { + // Indivisible forms never need parentheses around them + | EmptyHole + | Wild + | Invalid(_) + | Var(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | Constructor(_) => Precedence.max + + // Same goes for forms which are already surrounded + | ListLit(_) + | Parens(_) => Precedence.max + + // Other forms + | Cons(_) => Precedence.cons + | Ap(_) => Precedence.ap + | Cast(_) => Precedence.cast + | Tuple(_) => Precedence.prod + + // Matt: I think multiholes are min because we don't know the precedence of the `⟩?⟨`s + | MultiHole(_) => Precedence.min + }; + +let external_precedence_typ = (tp: Typ.t) => + switch (Typ.term_of(tp)) { + // Indivisible forms never need parentheses around them + | Unknown(Hole(Invalid(_))) + | Unknown(Internal) + | Unknown(SynSwitch) + | Unknown(Hole(EmptyHole)) + | Var(_) + | Int + | Float + | Bool + | String => Precedence.max + + // Same goes for forms which are already surrounded + | Parens(_) + | List(_) => Precedence.max + + // Other forms + | Prod(_) => Precedence.type_prod + | Ap(_) => Precedence.type_sum_ap + | Arrow(_, _) => Precedence.type_arrow + | Sum(_) => Precedence.type_plus + | Rec(_, _) => Precedence.let_ + | Forall(_, _) => Precedence.let_ + + // Matt: I think multiholes are min because we don't know the precedence of the `⟩?⟨`s + | Unknown(Hole(MultiHole(_))) => Precedence.min + }; + +let paren_at = (internal_precedence: Precedence.t, exp: Exp.t): Exp.t => + external_precedence(exp) >= internal_precedence + ? Exp.fresh(Parens(exp)) : exp; + +let paren_assoc_at = (internal_precedence: Precedence.t, exp: Exp.t): Exp.t => + external_precedence(exp) > internal_precedence + ? Exp.fresh(Parens(exp)) : exp; + +let paren_pat_at = (internal_precedence: Precedence.t, pat: Pat.t): Pat.t => + external_precedence_pat(pat) >= internal_precedence + ? Pat.fresh(Parens(pat)) : pat; + +let paren_pat_assoc_at = + (internal_precedence: Precedence.t, pat: Pat.t): Pat.t => + external_precedence_pat(pat) > internal_precedence + ? Pat.fresh(Parens(pat)) : pat; + +let paren_typ_at = (internal_precedence: Precedence.t, typ: Typ.t): Typ.t => + external_precedence_typ(typ) >= internal_precedence + ? Typ.fresh(Parens(typ)) : typ; + +let paren_typ_assoc_at = + (internal_precedence: Precedence.t, typ: Typ.t): Typ.t => + external_precedence_typ(typ) > internal_precedence + ? Typ.fresh(Parens(typ)) : typ; + +let rec parenthesize = (exp: Exp.t): Exp.t => { + let (term, rewrap) = Exp.unwrap(exp); + switch (term) { + // Indivisible forms dont' change + | Var(_) + | Invalid(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | EmptyHole + //| Constructor(_) // Not indivisible because of the type annotation! + | Deferral(_) + | BuiltinFun(_) + | Undefined => exp + + // Forms that currently need to stripped before outputting + | Closure(_, x) + | DynamicErrorHole(x, _) + | Tuple([x]) + | Filter(_, x) => x |> parenthesize + + // Other forms + | Constructor(c, t) => + Constructor(c, paren_typ_at(Precedence.cast, t)) |> rewrap + | Fun(p, e, c, n) => + Fun( + parenthesize_pat(p) |> paren_pat_at(Precedence.min), + parenthesize(e) |> paren_assoc_at(Precedence.fun_), + c, // TODO: Parenthesize through closure + n, + ) + |> rewrap + | TypFun(tp, e, n) => + TypFun(tp, parenthesize(e) |> paren_assoc_at(Precedence.fun_), n) + |> rewrap + | Tuple(es) => + Tuple( + es |> List.map(parenthesize) |> List.map(paren_at(Precedence.prod)), + ) + |> rewrap + | ListLit(es) => + ListLit( + es |> List.map(parenthesize) |> List.map(paren_at(Precedence.prod)), + ) + |> rewrap + | Let(p, e1, e2) => + Let( + parenthesize_pat(p) |> paren_pat_at(Precedence.min), + parenthesize(e1) |> paren_at(Precedence.min), + parenthesize(e2) |> paren_assoc_at(Precedence.let_), + ) + |> rewrap + | FixF(p, e, c) => + FixF( + parenthesize_pat(p) |> paren_pat_at(Precedence.min), + parenthesize(e) |> paren_assoc_at(Precedence.fun_), + c // TODO: Parenthesize through closure + ) + |> rewrap + | TyAlias(tp, t, e) => + TyAlias( + tp, + t, // TODO: Types + parenthesize(e) |> paren_assoc_at(Precedence.let_), + ) + |> rewrap + | Ap(Forward, e1, e2) => + Ap( + Forward, + parenthesize(e1) |> paren_assoc_at(Precedence.ap), + parenthesize(e2) |> paren_at(Precedence.min), + ) + |> rewrap + | Ap(Reverse, e1, e2) => + Ap( + Reverse, + parenthesize(e1) |> paren_assoc_at(Precedence.eqs), + parenthesize(e2) |> paren_at(Precedence.eqs), + ) + |> rewrap + | TypAp(e, tp) => + TypAp( + parenthesize(e) |> paren_assoc_at(Precedence.ap), + parenthesize_typ(tp) |> paren_typ_at(Precedence.min), + ) + |> rewrap + | DeferredAp(e, es) => + DeferredAp( + parenthesize(e) |> paren_assoc_at(Precedence.ap), + es |> List.map(parenthesize) |> List.map(paren_at(Precedence.prod)), + ) + |> rewrap + | If(e1, e2, e3) => + If( + parenthesize(e1) |> paren_at(Precedence.min), + parenthesize(e2) |> paren_at(Precedence.min), + parenthesize(e3) |> paren_assoc_at(Precedence.if_), + ) + |> rewrap + | Seq(e1, e2) => + Seq( + parenthesize(e1) |> paren_at(Precedence.semi), // tempting to make this one assoc too + parenthesize(e2) |> paren_assoc_at(Precedence.semi), + ) + |> rewrap + | Cast(e, t1, t2) => + Cast( + parenthesize(e) |> paren_assoc_at(Precedence.cast), + parenthesize_typ(t1) |> paren_typ_at(Precedence.cast), + parenthesize_typ(t2) |> paren_typ_at(Precedence.cast), + ) + |> rewrap + | FailedCast(e, t1, t2) => + FailedCast( + parenthesize(e) |> paren_at(Precedence.cast), + parenthesize_typ(t1) |> paren_typ_at(Precedence.cast), + parenthesize_typ(t2) |> paren_typ_at(Precedence.cast), + ) + |> rewrap + | Test(e) => Test(parenthesize(e) |> paren_at(Precedence.min)) |> rewrap + // | Filter(f, e) => + // Filter( + // f, // TODO: Filters + // parenthesize(e) |> paren_at(Precedence.min), + // ) + // |> rewrap + | Parens(e) => + Parens(parenthesize(e) |> paren_at(Precedence.min)) |> rewrap + | Cons(e1, e2) => + Cons( + parenthesize(e1) |> paren_at(Precedence.cons), + parenthesize(e2) |> paren_assoc_at(Precedence.cons), + ) + |> rewrap + | ListConcat(e1, e2) => + ListConcat( + parenthesize(e1) |> paren_at(Precedence.concat), + parenthesize(e2) |> paren_assoc_at(Precedence.concat), + ) + |> rewrap + | UnOp(Meta(Unquote), e) => + UnOp(Meta(Unquote), parenthesize(e) |> paren_at(Precedence.unquote)) + |> rewrap + | UnOp(Bool(Not), e) => + UnOp(Bool(Not), parenthesize(e) |> paren_at(Precedence.not_)) |> rewrap + | UnOp(Int(Minus), e) => + UnOp(Int(Minus), parenthesize(e) |> paren_at(Precedence.neg)) |> rewrap + | BinOp(op, e1, e2) => + BinOp( + op, + parenthesize(e1) |> paren_assoc_at(Precedence.of_bin_op(op)), + parenthesize(e2) |> paren_at(Precedence.of_bin_op(op)), + ) + |> rewrap + | Match(e, rs) => + Match( + parenthesize(e) |> paren_at(Precedence.min), + rs + |> List.map(((p, e)) => + ( + parenthesize_pat(p) |> paren_pat_at(Precedence.min), + parenthesize(e) |> paren_assoc_at(Precedence.case_), + ) + ), + ) + |> rewrap + | MultiHole(xs) => MultiHole(List.map(parenthesize_any, xs)) |> rewrap + }; +} +and parenthesize_pat = (pat: Pat.t): Pat.t => { + let (term, rewrap) = Pat.unwrap(pat); + switch (term) { + // Indivisible forms dont' change + | Var(_) + | Invalid(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | EmptyHole + | Constructor(_) => pat + + // Other forms + | Wild => pat + | Parens(p) => + Parens(parenthesize_pat(p) |> paren_pat_at(Precedence.min)) |> rewrap + | Cons(p1, p2) => + Cons( + parenthesize_pat(p1) |> paren_pat_at(Precedence.cons), + parenthesize_pat(p2) |> paren_pat_assoc_at(Precedence.cons), + ) + |> rewrap + | Tuple(ps) => + Tuple( + ps + |> List.map(parenthesize_pat) + |> List.map(paren_pat_at(Precedence.prod)), + ) + |> rewrap + | ListLit(ps) => + ListLit( + ps + |> List.map(parenthesize_pat) + |> List.map(paren_pat_at(Precedence.prod)), + ) + |> rewrap + | Ap(p1, p2) => + Ap( + parenthesize_pat(p1) |> paren_pat_assoc_at(Precedence.ap), + parenthesize_pat(p2) |> paren_pat_at(Precedence.min), + ) + |> rewrap + | MultiHole(xs) => MultiHole(List.map(parenthesize_any, xs)) |> rewrap + | Cast(p, t1, t2) => + Cast( + parenthesize_pat(p) |> paren_pat_assoc_at(Precedence.cast), + parenthesize_typ(t1) |> paren_typ_at(Precedence.max), // Hack[Matt]: always add parens to get the arrows right + parenthesize_typ(t2) |> paren_typ_at(Precedence.max), + ) + |> rewrap + }; +} + +and parenthesize_typ = (typ: Typ.t): Typ.t => { + let (term, rewrap) = Typ.unwrap(typ); + switch (term) { + // Indivisible forms dont' change + | Var(_) + | Unknown(Hole(Invalid(_))) + | Unknown(Internal) + | Unknown(SynSwitch) + | Unknown(Hole(EmptyHole)) + | Int + | Float + | Bool + | String => typ + + // Other forms + | Parens(t) => + Parens(parenthesize_typ(t) |> paren_typ_at(Precedence.min)) |> rewrap + | List(t) => + List(parenthesize_typ(t) |> paren_typ_at(Precedence.min)) |> rewrap + | Prod(ts) => + Prod( + ts + |> List.map(parenthesize_typ) + |> List.map(paren_typ_at(Precedence.type_prod)), + ) + |> rewrap + | Ap(t1, t2) => + Ap( + parenthesize_typ(t1) |> paren_typ_assoc_at(Precedence.type_sum_ap), + parenthesize_typ(t2) |> paren_typ_at(Precedence.min), + ) + |> rewrap + | Rec(tp, t) => + Rec( + tp, + parenthesize_typ(t) |> paren_typ_assoc_at(Precedence.type_binder), + ) + |> rewrap + | Forall(tp, t) => + Forall( + tp, + parenthesize_typ(t) |> paren_typ_assoc_at(Precedence.type_binder), + ) + |> rewrap + | Arrow(t1, t2) => + Arrow( + parenthesize_typ(t1) |> paren_typ_at(Precedence.type_arrow), + parenthesize_typ(t2) |> paren_typ_assoc_at(Precedence.type_arrow), + ) + |> rewrap + | Sum(ts) => + Sum( + ConstructorMap.map( + ts => + ts + |> Option.map(parenthesize_typ) + |> Option.map(paren_typ_at(Precedence.type_plus)), + ts, + ), + ) + |> rewrap + | Unknown(Hole(MultiHole(xs))) => + Unknown(Hole(MultiHole(List.map(parenthesize_any, xs)))) |> rewrap + }; +} + +and parenthesize_tpat = (tpat: TPat.t): TPat.t => { + let (term, rewrap: TPat.term => TPat.t) = IdTagged.unwrap(tpat); + switch (term) { + // Indivisible forms dont' change + | Var(_) + | Invalid(_) + | EmptyHole => tpat + + // Other forms + | MultiHole(xs) => MultiHole(List.map(parenthesize_any, xs)) |> rewrap + }; +} + +and parenthesize_rul = (rul: Rul.t): Rul.t => { + let (term, rewrap: Rul.term => Rul.t) = IdTagged.unwrap(rul); + switch (term) { + // Indivisible forms dont' change + | Invalid(_) => rul + + // Other forms + | Rules(e, ps) => + Rules( + parenthesize(e), + List.map(((p, e)) => (parenthesize_pat(p), parenthesize(e)), ps), + ) + |> rewrap + | Hole(xs) => Hole(List.map(parenthesize_any, xs)) |> rewrap + }; +} + +and parenthesize_any = (any: Any.t): Any.t => + switch (any) { + | Exp(e) => Exp(parenthesize(e)) + | Pat(p) => Pat(parenthesize_pat(p)) + | Typ(t) => Typ(parenthesize_typ(t)) + | TPat(tp) => TPat(parenthesize_tpat(tp)) + | Rul(r) => Rul(parenthesize_rul(r)) + | Any(_) => any + | Nul(_) => any + }; + +let exp_to_segment = (~settings, exp: Exp.t): Segment.t => { + let exp = exp |> Exp.substitute_closures(Builtins.env_init) |> parenthesize; + let p = exp_to_pretty(~settings, exp); + p |> PrettySegment.select; +}; + +let typ_to_segment = (~settings, typ: Typ.t): Segment.t => { + let typ = parenthesize_typ(typ); + let p = typ_to_pretty(~settings, typ); + p |> PrettySegment.select; +}; diff --git a/src/haz3lcore/pretty/PrettySegment.re b/src/haz3lcore/pretty/PrettySegment.re new file mode 100644 index 0000000000..ee8faa3f13 --- /dev/null +++ b/src/haz3lcore/pretty/PrettySegment.re @@ -0,0 +1,23 @@ +/* This file is a placeholder, ideally an algorithm would be implemented here that allows + efficient calculation of the best way to add linebreaks etc, but that hasn't been implemented yet, so + none of these functions do anything yet. (Matt) */ + +type pretty = Segment.t; + +let p_concat = (pretty2, pretty1) => pretty1 @ pretty2; +let p_or = (_pretty2, pretty1) => pretty1; +let p_orif = (cond, pretty2, pretty1) => if (cond) {pretty1} else {pretty2}; +let p_just = segment => segment; + +let p_concat = (pretties: list(pretty)) => + List.fold_left(p_concat, [], pretties); + +let (let+) = (pretty, f) => f(pretty); +let (and+) = (pretty1, pretty2) => (pretty1, pretty2); + +let ( let* ) = (pretty, f) => f(pretty); +let ( and* ) = (pretty1, pretty2) => (pretty1, pretty2); + +let all = x => x; + +let select: pretty => Segment.t = x => x; diff --git a/src/haz3lcore/prog/CachedStatics.re b/src/haz3lcore/prog/CachedStatics.re index 3df0669dc3..106ce24ab0 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -1,39 +1,55 @@ open Util; [@deriving (show({with_path: false}), sexp, yojson)] -type statics = { +type t = { term: UExp.t, + elaborated: UExp.t, info_map: Statics.Map.t, error_ids: list(Id.t), }; -let empty_statics: statics = { +let empty: t = { term: { ids: [Id.invalid], copied: false, term: Tuple([]), }, + elaborated: { + ids: [Id.invalid], + copied: false, + term: Tuple([]), + }, info_map: Id.Map.empty, error_ids: [], }; -module Key = { - include String; - [@deriving (show({with_path: false}), sexp, yojson)] - type t = string; -}; +let elaborate = + Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); -module M = Util.MapUtil.Make(Key); -include M; +let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; -[@deriving (show({with_path: false}), sexp, yojson)] -type t = M.t(statics); +let init_from_term = (~settings, term): t => { + let ctx_init = Builtins.ctx_init; + let info_map = Statics.mk(settings, ctx_init, term); + let error_ids = Statics.Map.error_ids(info_map); + let elaborated = + switch () { + | _ when !settings.statics => dh_err("Statics disabled") + | _ when !settings.dynamics && !settings.elaborate => + dh_err("Dynamics & Elaboration disabled") + | _ => + switch (elaborate(info_map, term)) { + | DoesNotElaborate => dh_err("Elaboration returns None") + | Elaborates(d, _, _) => d + } + }; + {term, elaborated, info_map, error_ids}; +}; -let mk = (ds: list((Key.t, statics))): t => - ds |> List.to_seq |> of_seq |> map(Fun.id); +let init = (~settings: CoreSettings.t, ~stitch, z: Zipper.t): t => { + let term = MakeTerm.from_zip_for_sem(z).term |> stitch; + init_from_term(~settings, term); +}; -let lookup = (results: t, key: Key.t) => - switch (find_opt(key, results)) { - | None => empty_statics - | Some(statics) => statics - }; +let init = (~settings: CoreSettings.t, ~stitch, z: Zipper.t) => + settings.statics ? init(~settings, ~stitch, z) : empty; diff --git a/src/haz3lcore/prog/Interface.re b/src/haz3lcore/prog/Interface.re deleted file mode 100644 index 3249b1aef2..0000000000 --- a/src/haz3lcore/prog/Interface.re +++ /dev/null @@ -1,34 +0,0 @@ -let dh_err = (error: string): DHExp.t => Var(error) |> DHExp.fresh; - -let elaborate = - Core.Memo.general(~cache_size_bound=1000, Elaborator.uexp_elab); - -exception DoesNotElaborate; -let elaborate = (~settings: CoreSettings.t, map, term): DHExp.t => - switch () { - | _ when !settings.statics => dh_err("Statics disabled") - | _ when !settings.dynamics && !settings.elaborate => - dh_err("Dynamics & Elaboration disabled") - | _ => - switch (elaborate(map, term)) { - | DoesNotElaborate => dh_err("Elaboration returns None") - | Elaborates(d, _, _) => d - } - }; - -let evaluate = - (~settings: CoreSettings.t, ~env=Builtins.env_init, elab: DHExp.t) - : ProgramResult.t => - switch () { - | _ when !settings.dynamics => Off({d: elab}) - | _ => - switch (Evaluator.evaluate(env, {d: elab})) { - | exception (EvaluatorError.Exception(reason)) => - print_endline("EvaluatorError:" ++ EvaluatorError.show(reason)); - ResultFail(EvaulatorError(reason)); - | exception exn => - print_endline("EXN:" ++ Printexc.to_string(exn)); - ResultFail(UnknownException(Printexc.to_string(exn))); - | (state, result) => ResultOk({result, state}) - } - }; diff --git a/src/haz3lcore/prog/ModelResult.re b/src/haz3lcore/prog/ModelResult.re deleted file mode 100644 index e8c8980a60..0000000000 --- a/src/haz3lcore/prog/ModelResult.re +++ /dev/null @@ -1,101 +0,0 @@ -[@deriving (show({with_path: false}), sexp, yojson)] -type eval_result = { - elab: Elaborator.Elaboration.t, - evaluation: ProgramResult.t, - previous: ProgramResult.t, -}; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | NoElab - | Evaluation(eval_result) - | Stepper(Stepper.t); - -let init_eval = (elab: Elaborator.Elaboration.t) => - Evaluation({elab, evaluation: ResultPending, previous: ResultPending}); - -let update_elab = (~settings, elab) => - fun - | NoElab => - Evaluation({elab, evaluation: ResultPending, previous: ResultPending}) - | Evaluation({evaluation, _}) => - Evaluation({elab, evaluation: ResultPending, previous: evaluation}) - | Stepper(s) as s' when DHExp.fast_equal(elab.d, Stepper.get_elab(s).d) => s' - | Stepper(_) => Stepper(Stepper.init(~settings, elab)); - -let update_stepper = f => - fun - | NoElab as e - | Evaluation(_) as e => e - | Stepper(s) => Stepper(f(s)); - -let step_forward = (idx: int, mr: t) => - mr |> update_stepper(Stepper.step_pending(idx)); - -let step_backward = (~settings, mr: t) => - mr |> update_stepper(Stepper.step_backward(~settings)); - -let run_pending = (~settings: CoreSettings.t) => - fun - | NoElab => NoElab - | Evaluation({elab, evaluation: ResultPending, previous}) => - Evaluation({ - elab, - previous, - evaluation: Interface.evaluate(~settings, elab.d), - }) - | Evaluation(_) as e => e - | Stepper(s) => - Stepper(Stepper.evaluate_pending(~settings=settings.evaluation, s)); - -let timeout: t => t = - fun - | NoElab => NoElab - | Evaluation({evaluation, _} as e) => - Evaluation({...e, evaluation: ResultFail(Timeout), previous: evaluation}) - | Stepper(s) => Stepper(Stepper.timeout(s)); - -let toggle_stepper = (~settings) => - fun - | NoElab => NoElab - | Evaluation({elab, _}) => Stepper(Stepper.init(~settings, elab)) - | Stepper(s) => - Evaluation({ - elab: Stepper.get_elab(s), - evaluation: ResultPending, - previous: ResultPending, - }); - -let test_results = (result: t) => - switch (result) { - | Evaluation({evaluation: ResultOk(pr), _}) - | Evaluation({ - evaluation: Off(_) | ResultFail(_) | ResultPending, - previous: ResultOk(pr), - _, - }) => - pr - |> ProgramResult.get_state - |> EvaluatorState.get_tests - |> TestResults.mk_results - |> Option.some - | Evaluation({evaluation: Off(_) | ResultFail(_) | ResultPending, _}) - | NoElab - | Stepper(_) => None - }; - -[@deriving (show({with_path: false}), sexp, yojson)] -type persistent = - | Evaluation - | Stepper(Stepper.persistent); - -let to_persistent: t => persistent = - fun - | NoElab - | Evaluation(_) => Evaluation - | Stepper(s) => Stepper(Stepper.to_persistent(s)); - -let of_persistent = (~settings) => - fun - | Evaluation => NoElab - | Stepper(s) => Stepper(Stepper.from_persistent(~settings, s)); diff --git a/src/haz3lcore/prog/ModelResults.re b/src/haz3lcore/prog/ModelResults.re deleted file mode 100644 index a49d287d07..0000000000 --- a/src/haz3lcore/prog/ModelResults.re +++ /dev/null @@ -1,78 +0,0 @@ -open Util; - -/* - ModelResults is used to store the results of - evaluations requested by the current editor mode, - with the key distinguishing these requests. - - See the SchoolExercise module for an example. - */ -module Key = { - include String; - [@deriving (show({with_path: false}), sexp, yojson)] - type t = string; -}; - -module M = Util.MapUtil.Make(Key); -include M; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = M.t(ModelResult.t); - -let init_eval = (ds: list((Key.t, Elaborator.Elaboration.t))): t => - ds |> List.to_seq |> of_seq |> map(ModelResult.init_eval); - -let update_elabs = (~settings) => - List.fold_right(((k, elab), acc) => - update( - k, - v => - Some( - v - |> Option.value(~default=ModelResult.NoElab) - |> ModelResult.update_elab(~settings, elab), - ), - acc, - ) - ); - -let lookup = (results: t, key: Key.t) => find_opt(key, results); - -let run_pending = (~settings) => M.map(ModelResult.run_pending(~settings)); - -let timeout_all = map(ModelResult.timeout); - -let advance_evaluator_result = - (results: t, (key: Key.t, elab: Elaborator.Elaboration.t)) - : option((Key.t, ModelResult.t)) => - switch (lookup(results, key)) { - | Some(Stepper(_)) => None - | Some(Evaluation({evaluation: previous, _})) => - Some((key, Evaluation({elab, evaluation: ResultPending, previous}))) - | Some(NoElab) - | None => - Some(( - key, - Evaluation({elab, evaluation: ResultPending, previous: ResultPending}), - )) - }; - -let stepper_result_opt = - ((key: Key.t, r: ModelResult.t)): option((Key.t, ModelResult.t)) => - switch (r) { - | Stepper(_) => Some((key, r)) - | _ => None - }; - -let to_evaluate = - (results: t, elabs: list((Key.t, Elaborator.Elaboration.t))): t => - elabs - |> List.filter_map(advance_evaluator_result(results)) - |> List.to_seq - |> of_seq; - -let to_step = (results: t): t => - bindings(results) - |> List.filter_map(stepper_result_opt) - |> List.to_seq - |> of_seq; diff --git a/src/haz3lcore/prog/ProgramResult.re b/src/haz3lcore/prog/ProgramResult.re index 58e2e9082e..fbbb313a08 100644 --- a/src/haz3lcore/prog/ProgramResult.re +++ b/src/haz3lcore/prog/ProgramResult.re @@ -1,5 +1,26 @@ open Util; +// TODO[Matt]: combine into one module + +module Result = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | BoxedValue(DHExp.t) + | Indet(DHExp.t); + + let unbox = + fun + | BoxedValue(d) + | Indet(d) => d; + + let fast_equal = (r1, r2) => + switch (r1, r2) { + | (BoxedValue(d1), BoxedValue(d2)) + | (Indet(d1), Indet(d2)) => DHExp.fast_equal(d1, d2) + | _ => false + }; +}; + /** The result of a program evaluation. Includes the {!type:EvaluatorResult.t}, the {!type:EvaluatorState}, and the tracked hole instance information @@ -7,7 +28,7 @@ open Util; */ [@deriving (show({with_path: false}), sexp, yojson)] type inner = { - result: Evaluator.Result.t, + result: Result.t, state: EvaluatorState.t, }; @@ -18,11 +39,19 @@ type error = | UnknownException(string); [@deriving (show({with_path: false}), sexp, yojson)] -type t = +type t('a) = | Off(Elaborator.Elaboration.t) - | ResultOk(inner) + | ResultOk('a) | ResultFail(error) | ResultPending; -let get_dhexp = (r: inner) => Evaluator.Result.unbox(r.result); +let get_dhexp = (r: inner) => Result.unbox(r.result); let get_state = (r: inner) => r.state; + +let map = (f: 'a => 'b, r: t('a)) => + switch (r) { + | Off(elab) => Off(elab) + | ResultOk(a) => ResultOk(f(a)) + | ResultFail(e) => ResultFail(e) + | ResultPending => ResultPending + }; diff --git a/src/haz3lcore/dynamics/Elaborator.re b/src/haz3lcore/statics/Elaborator.re similarity index 94% rename from src/haz3lcore/dynamics/Elaborator.re rename to src/haz3lcore/statics/Elaborator.re index 27ec1ef5b3..979a2128c8 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/statics/Elaborator.re @@ -18,16 +18,16 @@ module ElaborationResult = { | DoesNotElaborate; }; -let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { +let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): Exp.t => { Typ.eq(t1, t2) ? d : { - let d' = - Cast(d, t1, Typ.temp(Unknown(Internal))) - |> DHExp.fresh + let d': Exp.t = + (Cast(d, t1, Typ.temp(Unknown(Internal))): Exp.term) + |> IdTagged.fresh_deterministic(DHExp.rep_id(d)) |> Casts.transition_multiple; - Cast(d', Typ.temp(Unknown(Internal)), t2) - |> DHExp.fresh + (Cast(d', Typ.temp(Unknown(Internal)), t2): Exp.term) + |> IdTagged.fresh_deterministic(DHExp.rep_id(d')) |> Casts.transition_multiple; }; }; @@ -71,7 +71,7 @@ let elaborated_type = (m: Statics.Map.t, uexp: UExp.t): (Typ.t, Ctx.t, 'a) => { // We need to remove the synswitches from this type. | Ana(ana_ty) => Typ.match_synswitch(ana_ty, self_ty) }; - (elab_ty |> Typ.normalize(ctx), ctx, co_ctx); + (elab_ty |> Typ.normalize(ctx) |> Typ.all_ids_temp, ctx, co_ctx); }; let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { @@ -101,7 +101,7 @@ let elaborated_pat_type = (m: Statics.Map.t, upat: UPat.t): (Typ.t, Ctx.t) => { | Some(syn_ty) => Typ.match_synswitch(syn_ty, ana_ty) } }; - (elab_ty |> Typ.normalize(ctx), ctx); + (elab_ty |> Typ.normalize(ctx) |> Typ.all_ids_temp, ctx); }; let rec elaborate_pattern = @@ -155,14 +155,16 @@ let rec elaborate_pattern = upat |> cast_from( Ctx.lookup_var(ctx, v) - |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) + |> Option.map((x: Ctx.var_entry) => + x.typ |> Typ.normalize(ctx) |> Typ.all_ids_temp + ) |> Option.value(~default=Typ.temp(Unknown(Internal))), ) // Type annotations should already appear | Parens(p) | Cast(p, _, _) => let (p', ty) = elaborate_pattern(m, p); - p' |> cast_from(ty |> Typ.normalize(ctx)); + p' |> cast_from(ty |> Typ.normalize(ctx) |> Typ.all_ids_temp); | Constructor(c, _) => let mode = switch (Id.Map.find_opt(Pat.rep_id(upat), m)) { @@ -257,7 +259,7 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { | (_, Some({typ: syn_ty, _})) => syn_ty | _ => Unknown(Internal) |> Typ.temp }; - let t = t |> Typ.normalize(ctx); + let t = t |> Typ.normalize(ctx) |> Typ.all_ids_temp; Constructor(c, t) |> rewrap |> cast_from(t); | Fun(p, e, env, n) => let (p', typ) = elaborate_pattern(m, p); @@ -277,7 +279,9 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { uexp |> cast_from( Ctx.lookup_var(ctx, v) - |> Option.map((x: Ctx.var_entry) => x.typ |> Typ.normalize(ctx)) + |> Option.map((x: Ctx.var_entry) => + x.typ |> Typ.normalize(ctx) |> Typ.all_ids_temp + ) |> Option.value(~default=Typ.temp(Unknown(Internal))), ) | Let(p, def, body) => @@ -304,11 +308,12 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { Let(p, fresh_cast(def, ty2, ty1), body) |> rewrap |> cast_from(ty); } else { // TODO: Add names to mutually recursive functions - // TODO: Don't add fixpoint if there already is one let def = add_name(Option.map(s => s ++ "+", Pat.get_var(p)), def); let (def, ty2) = elaborate(m, def); let (body, ty) = elaborate(m, body); - let fixf = FixF(p, fresh_cast(def, ty2, ty1), None) |> DHExp.fresh; + let fixf = + (FixF(p, fresh_cast(def, ty2, ty1), None): Exp.term) + |> IdTagged.fresh_deterministic(DHExp.rep_id(uexp)); Let(p, fixf, body) |> rewrap |> cast_from(ty); }; | FixF(p, e, env) => @@ -563,5 +568,5 @@ let fix_typ_ids = let uexp_elab = (m: Statics.Map.t, uexp: UExp.t): ElaborationResult.t => switch (elaborate(m, uexp)) { | exception MissingTypeInfo => DoesNotElaborate - | (d, ty) => Elaborates(d, ty, Delta.empty) + | (d, ty) => Elaborates(d |> fix_typ_ids, ty, Delta.empty) }; diff --git a/src/haz3lcore/statics/MakeTerm.re b/src/haz3lcore/statics/MakeTerm.re index d1edb9d16a..06f5786879 100644 --- a/src/haz3lcore/statics/MakeTerm.re +++ b/src/haz3lcore/statics/MakeTerm.re @@ -275,6 +275,12 @@ and exp_term: unsorted => (UExp.term, list(Id.t)) = { } | _ => ret(hole(tm)) } + | Bin(Exp(l), tiles, Typ(r)) as tm => + switch (tiles) { + | ([(_id, ([":"], []))], []) => + ret(Cast(l, Unknown(Internal) |> Typ.fresh, r)) + | _ => ret(hole(tm)) + } | Bin(Exp(l), tiles, Exp(r)) as tm => switch (is_tuple_exp(tiles)) { | Some(between_kids) => ret(Tuple([l] @ between_kids @ [r])) diff --git a/src/haz3lcore/statics/Mode.re b/src/haz3lcore/statics/Mode.re index 2415399627..7cb288e637 100644 --- a/src/haz3lcore/statics/Mode.re +++ b/src/haz3lcore/statics/Mode.re @@ -108,8 +108,12 @@ let ctr_ana_typ = (ctx: Ctx.t, mode: t, ctr: Constructor.t): option(Typ.t) => { a sum type having that ctr as a variant, we consider the ctr's type to be determined by the sum type */ switch (mode) { - | Ana({term: Arrow(_, ty_ana), _}) | Ana(ty_ana) => + let ty_ana = + switch (Typ.matched_arrow_strict(ctx, ty_ana)) { + | Some((_, ty_ana)) => ty_ana + | None => ty_ana + }; let+ ctrs = Typ.get_sum_constructors(ctx, ty_ana); let ty_entry = ConstructorMap.get_entry(ctr, ctrs); switch (ty_entry) { diff --git a/src/haz3lcore/statics/Statics.re b/src/haz3lcore/statics/Statics.re index 443c94155b..4818a4aaf8 100644 --- a/src/haz3lcore/statics/Statics.re +++ b/src/haz3lcore/statics/Statics.re @@ -209,19 +209,21 @@ and uexp_to_info_map = ([], m), ); let go_pat = upat_to_info_map(~ctx, ~ancestors); + let go_typ = utyp_to_info_map(~ctx, ~ancestors); let atomic = self => add(~self, ~co_ctx=CoCtx.empty, m); switch (term) { - | Closure(_) => - failwith( - "TODO: implement closure type checking - see how dynamic type assignment does it", - ) + | Closure(_, e) => + // TODO: implement closure type checking properly - see how dynamic type assignment does it + let (e, m) = go(~mode, e, m); + add(~self=Just(e.ty), ~co_ctx=e.co_ctx, m); | MultiHole(tms) => let (co_ctxs, m) = multi(~ctx, ~ancestors, m, tms); add(~self=IsMulti, ~co_ctx=CoCtx.union(co_ctxs), m); - | Cast(e, t1, t2) - | FailedCast(e, t1, t2) => - let (e, m) = go(~mode=Ana(t1), e, m); - add(~self=Just(t2), ~co_ctx=e.co_ctx, m); + | Cast(e, _, t2) + | FailedCast(e, _, t2) => + let (t, m) = go_typ(t2, ~expects=Info.TypeExpected, m); + let (e, m) = go'(~mode=Ana(t.term), ~ctx=t.ctx, e, m); + add(~self=Just(t.term), ~co_ctx=e.co_ctx, m); | Invalid(token) => atomic(BadToken(token)) | EmptyHole => atomic(Just(Unknown(Internal) |> Typ.temp)) | Deferral(position) => diff --git a/src/haz3lcore/statics/Term.re b/src/haz3lcore/statics/Term.re index 92eef8161e..5677278b67 100644 --- a/src/haz3lcore/statics/Term.re +++ b/src/haz3lcore/statics/Term.re @@ -271,11 +271,29 @@ module Pat = { | Constructor(name, _) => Some(name) | _ => None }; + + let rec bound_vars = (dp: t): list(Var.t) => + switch (dp |> term_of) { + | EmptyHole + | MultiHole(_) + | Wild + | Invalid(_) + | Int(_) + | Float(_) + | Bool(_) + | String(_) + | Constructor(_) => [] + | Cast(y, _, _) + | Parens(y) => bound_vars(y) + | Var(y) => [y] + | Tuple(dps) => List.flatten(List.map(bound_vars, dps)) + | Cons(dp1, dp2) => bound_vars(dp1) @ bound_vars(dp2) + | ListLit(dps) => List.flatten(List.map(bound_vars, dps)) + | Ap(_, dp1) => bound_vars(dp1) + }; }; module Exp = { - include TermBase.Exp; - [@deriving (show({with_path: false}), sexp, yojson)] type cls = | Invalid @@ -318,6 +336,8 @@ module Exp = { | Cast | ListConcat; + include TermBase.Exp; + let hole = (tms: list(TermBase.Any.t)): term => switch (tms) { | [] => EmptyHole @@ -326,6 +346,7 @@ module Exp = { let rep_id: t => Id.t = IdTagged.rep_id; let fresh: term => t = IdTagged.fresh; + let term_of: t => term = IdTagged.term_of; let unwrap: t => (term, term => t) = IdTagged.unwrap; let cls_of_term: term => cls = @@ -551,6 +572,200 @@ module Exp = { | Constructor(_) => None }; }; + + let (replace_all_ids, replace_all_ids_typ) = { + let f: + 'a. + (IdTagged.t('a) => IdTagged.t('a), IdTagged.t('a)) => IdTagged.t('a) + = + (continue, exp) => {...exp, ids: [Id.mk()]} |> continue; + ( + map_term(~f_exp=f, ~f_pat=f, ~f_typ=f, ~f_tpat=f, ~f_rul=f), + Typ.map_term(~f_exp=f, ~f_pat=f, ~f_typ=f, ~f_tpat=f, ~f_rul=f), + ); + }; + + let rec substitute_closures = + ( + env: Environment.t, + old_bound_vars: list(string), + new_bound_vars: list(string), + ) => + map_term( + ~f_exp= + (cont, e) => { + let (term, rewrap) = unwrap(e); + switch (term) { + // Variables: lookup if bound + | Var(x) => + switch (Environment.lookup(env, x)) { + | Some(e) => + e + |> replace_all_ids + |> substitute_closures(env, old_bound_vars, new_bound_vars) + | None => + Var( + List.mem(x, old_bound_vars) + ? x : Var.free_name(x, new_bound_vars), + ) + |> rewrap + } + // Forms with environments: look up in new environment + | Closure(env, e) => + substitute_closures( + env |> ClosureEnvironment.map_of, + [], + new_bound_vars, + e, + ) + | Fun(p, e, Some(env), n) => + let pat_bound_vars = Pat.bound_vars(p); + Fun( + p, + substitute_closures( + env + |> ClosureEnvironment.map_of + |> Environment.without_keys(pat_bound_vars), + pat_bound_vars, + pat_bound_vars @ new_bound_vars, + e, + ), + None, + n, + ) + |> rewrap; + | FixF(p, e, Some(env)) => + let pat_bound_vars = Pat.bound_vars(p); + FixF( + p, + substitute_closures( + env + |> ClosureEnvironment.map_of + |> Environment.without_keys(pat_bound_vars), + pat_bound_vars, + pat_bound_vars @ new_bound_vars, + e, + ), + None, + ) + |> rewrap; + // Cases with binders: remove binder from env + | Let(p, e1, e2) => + let pat_bound_vars = Pat.bound_vars(p); + Let( + p, + substitute_closures(env, old_bound_vars, new_bound_vars, e1), + substitute_closures( + env |> Environment.without_keys(pat_bound_vars), + pat_bound_vars @ old_bound_vars, + pat_bound_vars @ new_bound_vars, + e2, + ), + ) + |> rewrap; + | Match(e, cases) => + Match( + substitute_closures(env, old_bound_vars, new_bound_vars, e), + cases + |> List.map(((p, e)) => { + let pat_bound_vars = Pat.bound_vars(p); + ( + p, + substitute_closures( + env |> Environment.without_keys(pat_bound_vars), + pat_bound_vars @ old_bound_vars, + pat_bound_vars @ new_bound_vars, + e, + ), + ); + }), + ) + |> rewrap + | Fun(p, e, None, n) => + let pat_bound_vars = Pat.bound_vars(p); + Fun( + p, + substitute_closures( + env |> Environment.without_keys(pat_bound_vars), + pat_bound_vars @ old_bound_vars, + pat_bound_vars @ new_bound_vars, + e, + ), + None, + n, + ) + |> rewrap; + | FixF(p, e, None) => + let pat_bound_vars = Pat.bound_vars(p); + FixF( + p, + substitute_closures( + env |> Environment.without_keys(pat_bound_vars), + pat_bound_vars @ old_bound_vars, + pat_bound_vars @ new_bound_vars, + e, + ), + None, + ) + |> rewrap; + // Other cases: recurse + | Invalid(_) + | EmptyHole + | MultiHole(_) + | DynamicErrorHole(_) + | FailedCast(_) + | Deferral(_) + | Bool(_) + | Int(_) + | Float(_) + | String(_) + | ListLit(_) + | Constructor(_) + | TypFun(_) + | Tuple(_) + | TyAlias(_) + | Ap(_) + | TypAp(_) + | DeferredAp(_) + | If(_) + | Seq(_) + | Test(_) + | Filter(_) + | Parens(_) + | Cons(_) + | ListConcat(_) + | UnOp(_) + | BinOp(_) + | BuiltinFun(_) + | Cast(_) + | Undefined => cont(e) + }; + }, + _, + ); + let substitute_closures = substitute_closures(_, [], []); + + let unfix = (e: t, p: Pat.t) => { + switch (e.term) { + | FixF(p1, e1, _) => + if (Pat.fast_equal(p, p1)) { + e1; + } else { + e; + } + | _ => e + }; + }; + + let rec get_fn_name = (e: t) => { + switch (e.term) { + | Fun(_, _, _, n) => n + | FixF(_, e, _) => get_fn_name(e) + | Parens(e) => get_fn_name(e) + | TypFun(_, _, n) => n + | _ => None + }; + }; }; module Rul = { diff --git a/src/haz3lcore/statics/TermBase.re b/src/haz3lcore/statics/TermBase.re index 02bd8400d4..e8c4b339f3 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -306,7 +306,8 @@ and Exp: { | Undefined => term | MultiHole(things) => MultiHole(List.map(any_map_term, things)) | DynamicErrorHole(e, err) => DynamicErrorHole(exp_map_term(e), err) - | FailedCast(e, t1, t2) => FailedCast(exp_map_term(e), t1, t2) + | FailedCast(e, t1, t2) => + FailedCast(exp_map_term(e), typ_map_term(t1), typ_map_term(t2)) | ListLit(ts) => ListLit(List.map(exp_map_term, ts)) | Fun(p, e, env, f) => Fun(pat_map_term(p), exp_map_term(e), env, f) @@ -343,7 +344,8 @@ and Exp: { rls, ), ) - | Cast(e, t1, t2) => Cast(exp_map_term(e), t1, t2) + | Cast(e, t1, t2) => + Cast(exp_map_term(e), typ_map_term(t1), typ_map_term(t2)) }, }; x |> f_exp(rec_call); @@ -938,6 +940,7 @@ and ClosureEnvironment: { let fold: (((Var.t, Exp.t), 'b) => 'b, 'b, t) => 'b; let without_keys: (list(Var.t), t) => t; + let with_symbolic_keys: (list(Var.t), t) => t; let placeholder: t; } = { @@ -1015,6 +1018,12 @@ and ClosureEnvironment: { let placeholder = wrap(Id.invalid, Environment.empty); let without_keys = keys => update(Environment.without_keys(keys)); + let with_symbolic_keys = (keys, env) => + List.fold_right( + (key, env) => extend(env, (key, Var(key) |> IdTagged.fresh)), + keys, + env, + ); } and StepperFilterKind: { [@deriving (show({with_path: false}), sexp, yojson)] diff --git a/src/haz3lcore/statics/Var.re b/src/haz3lcore/statics/Var.re index 68c3d9d1b3..a840aa33e7 100644 --- a/src/haz3lcore/statics/Var.re +++ b/src/haz3lcore/statics/Var.re @@ -27,3 +27,10 @@ let split = (pos, name) => { /* Used for VarBstMap */ let compare = (x: t, y: t) => compare(x, y); + +let rec free_name = (x: t, bound: list(t)) => + if (List.mem(x, bound)) { + free_name(x ++ "'", bound); + } else { + x; + }; diff --git a/src/haz3lcore/tiles/Id.re b/src/haz3lcore/tiles/Id.re index 5046dd63c5..327c3af1b0 100644 --- a/src/haz3lcore/tiles/Id.re +++ b/src/haz3lcore/tiles/Id.re @@ -59,6 +59,10 @@ let t_of_yojson: Yojson.Safe.t => Uuidm.t = type t = Uuidm.t; let mk: unit => t = Uuidm.v4_gen(Random.State.make_self_init()); +let namespace_uuid = + Uuidm.of_string("6ba7b810-9dad-11d1-80b4-00c04fd430c8") + |> Util.OptUtil.get(_ => failwith("Invalid namespace UUID")); +let next: t => t = x => Uuidm.v5(namespace_uuid, Uuidm.to_string(x)); let compare: (t, t) => int = Uuidm.compare; let to_string: (~upper: bool=?, t) => string = Uuidm.to_string; diff --git a/src/haz3lcore/tiles/Secondary.re b/src/haz3lcore/tiles/Secondary.re index c973469254..7db7861256 100644 --- a/src/haz3lcore/tiles/Secondary.re +++ b/src/haz3lcore/tiles/Secondary.re @@ -24,6 +24,8 @@ let cls_of = (s: t): cls => let mk_space = id => {content: Whitespace(Form.space), id}; +let mk_newline = id => {content: Whitespace(Form.linebreak), id}; + let construct_comment = content => if (String.equal(content, "#")) { Comment("##"); diff --git a/src/haz3lcore/tiles/Segment.re b/src/haz3lcore/tiles/Segment.re index de8689f08a..e4ad513fa6 100644 --- a/src/haz3lcore/tiles/Segment.re +++ b/src/haz3lcore/tiles/Segment.re @@ -128,11 +128,15 @@ and remold_typ = (shape, seg: t): t => | Tile(t) => switch (remold_tile(Typ, shape, t)) { | None => [Tile(t), ...remold_typ(snd(Tile.shapes(t)), tl)] + | Some(t) when !Tile.has_end(Right, t) => + let (_, r) = Tile.nibs(t); + let remolded = remold(~shape=r.shape, tl, r.sort); + [Tile(t), ...remolded]; | Some(t) => [Tile(t), ...remold_typ(snd(Tile.shapes(t)), tl)] } } } -and remold_typ_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_typ_uni = (shape, seg: t, parent_sorts): (t, Nib.Shape.t, t) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -140,7 +144,7 @@ and remold_typ_uni = (shape, seg: t): (t, Nib.Shape.t, t) => | Secondary(_) | Grout(_) | Projector(_) => - let (remolded, shape, rest) = remold_typ_uni(shape, tl); + let (remolded, shape, rest) = remold_typ_uni(shape, tl, parent_sorts); ([hd, ...remolded], shape, rest); | Tile(t) => switch (remold_tile(Typ, shape, t)) { @@ -150,19 +154,23 @@ and remold_typ_uni = (shape, seg: t): (t, Nib.Shape.t, t) => let remolded = remold(~shape=r.shape, tl, r.sort); let (_, shape, _) = shape_affix(Left, remolded, r.shape); ([Tile(t), ...remolded], shape, []); - | Some(t) when t.label == Form.get("comma_typ").label => ( + | Some(t) + when + t.label == Form.get("comma_typ").label + || t.label == Form.get("typ_plus").label + && List.exists((==)(Sort.Exp), parent_sorts) => ( [], shape, seg, ) | Some(t) => let (remolded, shape, rest) = - remold_typ_uni(snd(Tile.shapes(t)), tl); + remold_typ_uni(snd(Tile.shapes(t)), tl, parent_sorts); ([Tile(t), ...remolded], shape, rest); } } } -and remold_pat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_pat_uni = (shape, seg: t, parent_sorts): (t, Nib.Shape.t, t) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -170,7 +178,7 @@ and remold_pat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => | Secondary(_) | Grout(_) | Projector(_) => - let (remolded, shape, rest) = remold_pat_uni(shape, tl); + let (remolded, shape, rest) = remold_pat_uni(shape, tl, parent_sorts); ([hd, ...remolded], shape, rest); | Tile(t) => switch (remold_tile(Pat, shape, t)) { @@ -183,12 +191,14 @@ and remold_pat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => | Some(t) => switch (Tile.nibs(t)) { | (_, {shape, sort: Typ}) => - let (remolded_typ, shape, rest) = remold_typ_uni(shape, tl); - let (remolded_pat, shape, rest) = remold_pat_uni(shape, rest); + let (remolded_typ, shape, rest) = + remold_typ_uni(shape, tl, [Sort.Pat, ...parent_sorts]); + let (remolded_pat, shape, rest) = + remold_pat_uni(shape, rest, parent_sorts); ([Piece.Tile(t), ...remolded_typ] @ remolded_pat, shape, rest); | _ => let (remolded, shape, rest) = - remold_pat_uni(snd(Tile.shapes(t)), tl); + remold_pat_uni(snd(Tile.shapes(t)), tl, parent_sorts); ([Tile(t), ...remolded], shape, rest); } } @@ -205,17 +215,22 @@ and remold_pat = (shape, seg: t): t => | Tile(t) => switch (remold_tile(Pat, shape, t)) { | None => [Tile(t), ...remold_pat(snd(Tile.shapes(t)), tl)] + | Some(t) when !Tile.has_end(Right, t) => + let (_, r) = Tile.nibs(t); + let remolded = remold(~shape=r.shape, tl, r.sort); + [Tile(t), ...remolded]; | Some(t) => switch (Tile.nibs(t)) { | (_, {shape, sort: Typ}) => - let (remolded, shape, rest) = remold_typ_uni(shape, tl); + let (remolded, shape, rest) = + remold_typ_uni(shape, tl, [Sort.Pat]); [Piece.Tile(t), ...remolded] @ remold_pat(shape, rest); | _ => [Tile(t), ...remold_pat(snd(Tile.shapes(t)), tl)] } } } } -and remold_tpat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_tpat_uni = (shape, seg: t, parent_sorts): (t, Nib.Shape.t, t) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -223,7 +238,7 @@ and remold_tpat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => | Secondary(_) | Grout(_) | Projector(_) => - let (remolded, shape, rest) = remold_tpat_uni(shape, tl); + let (remolded, shape, rest) = remold_tpat_uni(shape, tl, parent_sorts); ([hd, ...remolded], shape, rest); | Tile(t) => switch (remold_tile(TPat, shape, t)) { @@ -237,7 +252,7 @@ and remold_tpat_uni = (shape, seg: t): (t, Nib.Shape.t, t) => switch (Tile.nibs(t)) { | _ => let (remolded, shape, rest) = - remold_tpat_uni(snd(Tile.shapes(t)), tl); + remold_tpat_uni(snd(Tile.shapes(t)), tl, parent_sorts); ([Tile(t), ...remolded], shape, rest); } } @@ -254,17 +269,22 @@ and remold_tpat = (shape, seg: t): t => | Tile(t) => switch (remold_tile(TPat, shape, t)) { | None => [Tile(t), ...remold_tpat(snd(Tile.shapes(t)), tl)] + | Some(t) when !Tile.has_end(Right, t) => + let (_, r) = Tile.nibs(t); + let remolded = remold(~shape=r.shape, tl, r.sort); + [Tile(t), ...remolded]; | Some(t) => switch (Tile.nibs(t)) { | (_, {shape, sort: Typ}) => - let (remolded, shape, rest) = remold_typ_uni(shape, tl); + let (remolded, shape, rest) = + remold_typ_uni(shape, tl, [Sort.TPat]); [Piece.Tile(t), ...remolded] @ remold_tpat(shape, rest); | _ => [Tile(t), ...remold_tpat(snd(Tile.shapes(t)), tl)] } } } } -and remold_exp_uni = (shape, seg: t): (t, Nib.Shape.t, t) => +and remold_exp_uni = (shape, seg: t, parent_sorts): (t, Nib.Shape.t, t) => switch (seg) { | [] => ([], shape, []) | [hd, ...tl] => @@ -272,7 +292,7 @@ and remold_exp_uni = (shape, seg: t): (t, Nib.Shape.t, t) => | Secondary(_) | Grout(_) | Projector(_) => - let (remolded, shape, rest) = remold_exp_uni(shape, tl); + let (remolded, shape, rest) = remold_exp_uni(shape, tl, parent_sorts); ([hd, ...remolded], shape, rest); | Tile(t) => switch (remold_tile(Exp, shape, t)) { @@ -285,23 +305,29 @@ and remold_exp_uni = (shape, seg: t): (t, Nib.Shape.t, t) => | Some(t) => switch (Tile.nibs(t)) { | (_, {shape, sort: TPat}) => - let (remolded_tpat, shape, rest) = remold_tpat_uni(shape, tl); - let (remolded_exp, shape, rest) = remold_exp_uni(shape, rest); + let (remolded_tpat, shape, rest) = + remold_tpat_uni(shape, tl, [Sort.Exp, ...parent_sorts]); + let (remolded_exp, shape, rest) = + remold_exp_uni(shape, rest, parent_sorts); ([Piece.Tile(t), ...remolded_tpat] @ remolded_exp, shape, rest); | (_, {shape, sort: Pat}) => - let (remolded_pat, shape, rest) = remold_pat_uni(shape, tl); - let (remolded_exp, shape, rest) = remold_exp_uni(shape, rest); + let (remolded_pat, shape, rest) = + remold_pat_uni(shape, tl, [Sort.Exp, ...parent_sorts]); + let (remolded_exp, shape, rest) = + remold_exp_uni(shape, rest, parent_sorts); ([Piece.Tile(t), ...remolded_pat] @ remolded_exp, shape, rest); | (_, {shape, sort: Typ}) => - let (remolded_typ, shape, rest) = remold_typ_uni(shape, tl); - let (remolded_exp, shape, rest) = remold_exp_uni(shape, rest); + let (remolded_typ, shape, rest) = + remold_typ_uni(shape, tl, [Sort.Exp, ...parent_sorts]); + let (remolded_exp, shape, rest) = + remold_exp_uni(shape, rest, parent_sorts); ([Piece.Tile(t), ...remolded_typ] @ remolded_exp, shape, rest); | (_, {shape, sort: Rul}) => // TODO review short circuit ([Tile(t)], shape, tl) | _ => let (remolded, shape, rest) = - remold_exp_uni(snd(Tile.shapes(t)), tl); + remold_exp_uni(snd(Tile.shapes(t)), tl, parent_sorts); ([Tile(t), ...remolded], shape, rest); } } @@ -317,19 +343,27 @@ and remold_rul = (shape, seg: t): t => | Projector(_) => [hd, ...remold_rul(shape, tl)] | Tile(t) => switch (remold_tile(Rul, shape, t)) { + | Some(t) when !Tile.has_end(Right, t) => + let (_, r) = Tile.nibs(t); + let remolded = remold(~shape=r.shape, tl, r.sort); + [Tile(t), ...remolded]; | Some(t) => switch (Tile.nibs(t)) { | (_, {shape, sort: Exp}) => - let (remolded, shape, rest) = remold_exp_uni(shape, tl); + let (remolded, shape, rest) = + remold_exp_uni(shape, tl, [Sort.Rul]); [Piece.Tile(t), ...remolded] @ remold_rul(shape, rest); | (_, {shape, sort: Pat}) => - let (remolded, shape, rest) = remold_pat_uni(shape, tl); + let (remolded, shape, rest) = + remold_pat_uni(shape, tl, [Sort.Rul]); // TODO(d) continuing onto rule might not be right right... [Piece.Tile(t), ...remolded] @ remold_rul(shape, rest); | _ => failwith("remold_rul unexpected") } | None => - let (remolded, shape, rest) = remold_exp_uni(shape, [hd, ...tl]); + // TODO: not sure whether we should add Rul to parent_sorts here + let (remolded, shape, rest) = + remold_exp_uni(shape, [hd, ...tl], []); switch (remolded) { | [] => [Piece.Tile(t), ...remold_rul(shape, tl)] | [_, ..._] => remolded @ remold_rul(shape, rest) @@ -348,16 +382,20 @@ and remold_exp = (shape, seg: t): t => | Tile(t) => switch (remold_tile(Exp, shape, t)) { | None => [Tile(t), ...remold_exp(snd(Tile.shapes(t)), tl)] + | Some(t) when !Tile.has_end(Right, t) => + let (_, r) = Tile.nibs(t); + let remolded = remold(~shape=r.shape, tl, r.sort); + [Tile(t), ...remolded]; | Some(t) => switch (Tile.nibs(t)) { | (_, {shape, sort: Pat}) => - let (remolded, shape, rest) = remold_pat_uni(shape, tl); + let (remolded, shape, rest) = remold_pat_uni(shape, tl, [Exp]); [Piece.Tile(t), ...remolded] @ remold_exp(shape, rest); | (_, {shape, sort: TPat}) => - let (remolded, shape, rest) = remold_tpat_uni(shape, tl); + let (remolded, shape, rest) = remold_tpat_uni(shape, tl, [Exp]); [Piece.Tile(t), ...remolded] @ remold_exp(shape, rest); | (_, {shape, sort: Typ}) => - let (remolded, shape, rest) = remold_typ_uni(shape, tl); + let (remolded, shape, rest) = remold_typ_uni(shape, tl, [Exp]); [Piece.Tile(t), ...remolded] @ remold_exp(shape, rest); | (_, {shape, sort: Rul}) => [Tile(t), ...remold_rul(shape, tl)] | _ => [Tile(t), ...remold_exp(snd(Tile.shapes(t)), tl)] @@ -674,3 +712,22 @@ and ids_of_piece = (p: Piece.t): list(Id.t) => | Secondary(_) | Projector(_) => [Piece.id(p)] }; + +let first_string = + fun + | [] => "EMPTY" + | [Piece.Secondary(w), ..._] => Secondary.get_string(w.content) + | [Piece.Projector(_), ..._] => "PROJECTOR" + | [Piece.Grout(_), ..._] => "?" + | [Piece.Tile(t), ..._] => t.label |> List.hd; + +let last_string = + fun + | [] => "EMPTY" + | xs => + switch (ListUtil.last(xs)) { + | Piece.Secondary(w) => Secondary.get_string(w.content) + | Piece.Grout(_) => "?" + | Piece.Projector(_) => "PROJECTOR" + | Piece.Tile(t) => t.label |> ListUtil.last + }; diff --git a/src/haz3lcore/tiles/Tile.re b/src/haz3lcore/tiles/Tile.re index df9350c4ff..937b4d06e4 100644 --- a/src/haz3lcore/tiles/Tile.re +++ b/src/haz3lcore/tiles/Tile.re @@ -8,7 +8,7 @@ exception Empty_tile; [@deriving (show({with_path: false}), sexp, yojson)] type t = tile; -let id = t => t.id; +let id = (t: t) => t.id; let is_complete = (t: t) => List.length(t.label) == List.length(t.shards); diff --git a/src/haz3lcore/zipper/Editor.re b/src/haz3lcore/zipper/Editor.re index bdb3e014cc..819ae28bf3 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -1,47 +1,8 @@ open Util; -module CachedStatics = { - type t = { - term: UExp.t, - info_map: Statics.Map.t, - error_ids: list(Id.t), - }; - - let empty: t = { - term: { - ids: [Id.invalid], - copied: false, - term: Tuple([]), - }, - info_map: Id.Map.empty, - error_ids: [], - }; - - let init = (~settings: CoreSettings.t, z: Zipper.t): t => { - // Modify here to allow passing in an initial context - let ctx_init = Builtins.ctx_init; - let term = MakeTerm.from_zip_for_sem(z).term; - let info_map = Statics.mk(settings, ctx_init, term); - let error_ids = Statics.Map.error_ids(info_map); - {term, info_map, error_ids}; - }; - - let init = (~settings: CoreSettings.t, z: Zipper.t) => - settings.statics ? init(~settings, z) : empty; - - let next = - (~settings: CoreSettings.t, a: Action.t, z: Zipper.t, old_statics: t): t => - if (!settings.statics) { - empty; - } else if (!Action.is_edit(a)) { - old_statics; - } else { - init(~settings, z); - }; -}; - module CachedSyntax = { type t = { + old: bool, segment: Segment.t, measured: Measured.t, tiles: TileMap.t, @@ -66,10 +27,17 @@ module CachedSyntax = { projectors: Id.Map.t(Base.projector), }; + // should not be serializing + let sexp_of_t = _ => failwith("Editor.Meta.sexp_of_t"); + let t_of_sexp = _ => failwith("Editor.Meta.t_of_sexp"); + let yojson_of_t = _ => failwith("Editor.Meta.yojson_of_t"); + let t_of_yojson = _ => failwith("Editor.Meta.t_of_yojson"); + let init = (z, info_map): t => { let segment = Zipper.unselect_and_zip(z); let MakeTerm.{term, terms, projectors} = MakeTerm.go(segment); { + old: false, segment, term_ranges: TermRanges.mk(segment), tiles: TileMap.mk(segment), @@ -82,72 +50,19 @@ module CachedSyntax = { }; }; - let next = (a: Action.t, z: Zipper.t, info_map, old: t) => - Action.is_edit(a) + let mark_old: t => t = old => {...old, old: true}; + + let calculate = (z: Zipper.t, info_map, old: t) => + old.old ? init(z, info_map) : {...old, selection_ids: Selection.selection_ids(z.selection)}; }; -module Meta = { - type t = { - col_target: int, - statics: CachedStatics.t, - syntax: CachedSyntax.t, - }; - - let init = (~settings: CoreSettings.t, z: Zipper.t) => { - let statics = CachedStatics.init(~settings, z); - {col_target: 0, statics, syntax: CachedSyntax.init(z, statics.info_map)}; - }; - - module type S = { - let measured: Measured.t; - let term_ranges: TermRanges.t; - let col_target: int; - }; - let module_of_t = (m: t): (module S) => - (module - { - let measured = m.syntax.measured; - let term_ranges = m.syntax.term_ranges; - let col_target = m.col_target; - }); - - // should not be serializing - let sexp_of_t = _ => failwith("Editor.Meta.sexp_of_t"); - let t_of_sexp = _ => failwith("Editor.Meta.t_of_sexp"); - let yojson_of_t = _ => failwith("Editor.Meta.yojson_of_t"); - let t_of_yojson = _ => failwith("Editor.Meta.t_of_yojson"); - - let next = (~settings: CoreSettings.t, a: Action.t, z: Zipper.t, meta: t): t => { - let syntax = CachedSyntax.next(a, z, meta.statics.info_map, meta.syntax); - let statics = CachedStatics.next(~settings, a, z, meta.statics); - let col_target = - switch (a) { - | Move(Local(Up | Down)) - | Select(Resize(Local(Up | Down))) => meta.col_target - | _ => (Zipper.caret_point(syntax.measured))(. z).col - }; - {col_target, syntax, statics}; - }; -}; - module State = { [@deriving (show({with_path: false}), sexp, yojson)] type t = { zipper: Zipper.t, - [@opaque] - meta: Meta.t, - }; - - let init = (zipper, ~settings: CoreSettings.t) => { - zipper, - meta: Meta.init(zipper, ~settings), - }; - - let next = (~settings: CoreSettings.t, a: Action.t, z: Zipper.t, state) => { - zipper: z, - meta: Meta.next(~settings, a, z, state.meta), + col_target: option(int), }; }; @@ -165,86 +80,203 @@ module History = { ); }; -[@deriving (show({with_path: false}), sexp, yojson)] -type t = { - state: State.t, - history: History.t, - read_only: bool, -}; - -let init = (~read_only=false, z, ~settings: CoreSettings.t) => { - state: State.init(z, ~settings), - history: History.empty, - read_only, -}; - -let new_state = - (~settings: CoreSettings.t, a: Action.t, z: Zipper.t, ed: t): t => { - let state = State.next(~settings, a, z, ed.state); - let history = - Action.is_historic(a) - ? History.add(a, ed.state, ed.history) : ed.history; - {state, history, read_only: ed.read_only}; -}; +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + // Updated + state: State.t, + history: History.t, + // Calculated + [@opaque] + syntax: CachedSyntax.t, + }; -let update_statics = (~settings: CoreSettings.t, ed: t): t => { - /* Use this function to force a statics update when (for example) - * changing the statics settings */ - let statics = CachedStatics.init(~settings, ed.state.zipper); - { - ...ed, + let mk = zipper => { state: { - ...ed.state, - meta: { - ...ed.state.meta, - statics, - }, + zipper, + col_target: None, }, + history: History.empty, + syntax: CachedSyntax.init(zipper, Id.Map.empty), }; -}; -let undo = (ed: t) => - switch (ed.history) { - | ([], _) => None - | ([(a, prev), ...before], after) => - Some({ - state: prev, - history: (before, [(a, ed.state), ...after]), - read_only: ed.read_only, - }) + type persistent = PersistentZipper.t; + let persist = (model: t) => model.state.zipper |> PersistentZipper.persist; + let unpersist = p => p |> PersistentZipper.unpersist |> mk; + + let to_move_s = (model: t): (module Move.S) => { + module M: Move.S = { + let measured = model.syntax.measured; + let term_ranges = model.syntax.term_ranges; + let col_target = model.state.col_target |> Option.value(~default=0); + }; + (module M); }; -let redo = (ed: t) => - switch (ed.history) { - | (_, []) => None - | (before, [(a, next), ...after]) => - Some({ - state: next, - history: ([(a, ed.state), ...before], after), - read_only: ed.read_only, - }) + + let trailing_hole_ctx = (ed: t, info_map: Statics.Map.t) => { + let segment = Zipper.unselect_and_zip(ed.state.zipper); + let convex_grout = Segment.convex_grout(segment); + // print_endline(String.concat("; ", List.map(Grout.show, convex_grout))); + let last = Util.ListUtil.last_opt(convex_grout); + switch (last) { + | None => None + | Some(grout) => + let id = grout.id; + let info = Id.Map.find_opt(id, info_map); + switch (info) { + | Some(info) => Some(Info.ctx_of(info)) + | _ => None + }; + }; + }; + + let indicated_projector = (editor: t) => + Projector.indicated(editor.state.zipper); +}; + +module Update = { + type t = Action.t; + + let update = + ( + ~settings: CoreSettings.t, + a: Action.t, + old_statics, + {state, history, syntax}: Model.t, + ) + : Action.Result.t(Model.t) => { + open Result.Syntax; + // 1. Clear the autocomplete buffer if relevant + let state = + settings.assist && settings.statics && a != Buffer(Accept) + ? { + ...state, + zipper: + Perform.go_z( + ~settings, + old_statics, + Buffer(Clear), + Model.to_move_s({state, history, syntax}), + state.zipper, + ) + |> Action.Result.ok + |> Option.value(~default=state.zipper), + } + : state; + let syntax = + if (settings.assist && settings.statics && a != Buffer(Accept)) { + CachedSyntax.mark_old(syntax); + } else { + syntax; + }; + + // 2. Add to undo history + let history = + Action.is_historic(a) ? History.add(a, state, history) : history; + + // 3. Record target column if moving up/down + let col_target = + switch (a) { + | Move(Local(Up | Down)) + | Select(Resize(Local(Up | Down))) => + switch (state.col_target) { + | Some(col) => Some(col) + | None => Some(Zipper.caret_point(syntax.measured, state.zipper).col) + } + | _ => None + }; + let state = {...state, col_target}; + + // 4. Update the zipper + let+ zipper = + Perform.go_z( + ~settings, + old_statics, + a, + Model.to_move_s({state, history, syntax}), + state.zipper, + ); + + // Recombine + Model.{ + state: { + zipper, + col_target, + }, + history, + syntax, + }; }; -let can_undo = ed => Option.is_some(undo(ed)); -let can_redo = ed => Option.is_some(redo(ed)); - -let set_read_only = (ed, read_only) => {...ed, read_only}; - -let trailing_hole_ctx = (ed: t, info_map: Statics.Map.t) => { - let segment = Zipper.unselect_and_zip(ed.state.zipper); - let convex_grout = Segment.convex_grout(segment); - // print_endline(String.concat("; ", List.map(Grout.show, convex_grout))); - let last = Util.ListUtil.last_opt(convex_grout); - switch (last) { - | None => None - | Some(grout) => - let id = grout.id; - let info = Id.Map.find_opt(id, info_map); - switch (info) { - | Some(info) => Some(Info.ctx_of(info)) - | _ => None + let undo = (ed: Model.t) => + switch (ed.history) { + | ([], _) => None + | ([(a, prev), ...before], after) => + Some( + Model.{ + state: prev, + history: (before, [(a, ed.state), ...after]), + syntax: ed.syntax // Will be recalculated in calculate + }, + ) + }; + let redo = (ed: Model.t) => + switch (ed.history) { + | (_, []) => None + | (before, [(a, next), ...after]) => + Some( + Model.{ + state: next, + history: ([(a, ed.state), ...before], after), + syntax: ed.syntax // Will be recalculated in calculate + }, + ) + }; + + let can_undo = ed => Option.is_some(undo(ed)); + let can_redo = ed => Option.is_some(redo(ed)); + + let calculate = + ( + ~settings: CoreSettings.t, + ~is_edited, + new_statics, + {syntax, state, history}: Model.t, + ) => { + // 1. Recalculate the autocomplete buffer if necessary + let zipper = + if (settings.assist && settings.statics && is_edited) { + switch ( + Perform.go_z( + ~settings, + new_statics, + Buffer(Set(TyDi)), + Model.to_move_s({syntax, state, history}), + state.zipper, + ) + ) { + | Ok(z) => z + | Error(_) => state.zipper + }; + } else { + state.zipper; + }; + // 2. Recalculate syntax cache + let syntax = is_edited ? CachedSyntax.mark_old(syntax) : syntax; + + let syntax = CachedSyntax.calculate(zipper, new_statics.info_map, syntax); + + // Recombine + Model.{ + history, + state: { + ...state, + zipper, + }, + syntax, }; }; }; -let indicated_projector = (editor: t) => - Projector.indicated(editor.state.zipper); +[@deriving (show({with_path: false}), sexp, yojson)] +type t = Model.t; diff --git a/src/haz3lcore/zipper/EditorUtil.re b/src/haz3lcore/zipper/EditorUtil.re index 23265f8a2a..bcc3a1aa5d 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -46,3 +46,20 @@ let rec append_exp = (e1: Exp.t, e2: Exp.t): Exp.t => { {ids: e1.ids, copied: false, term: TyAlias(tp, tdef, ebody')}; }; }; + +let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => { + term: + Filter( + Filter({ + act: FilterAction.(act, One), + pat: { + term: Constructor("$e", Unknown(Internal) |> Typ.fresh), + copied: false, + ids: [Id.mk()], + }, + }), + term, + ), + copied: false, + ids: [Id.mk()], +}; diff --git a/src/haz3lcore/zipper/Printer.re b/src/haz3lcore/zipper/Printer.re index e6af6911ec..1ab6b176f5 100644 --- a/src/haz3lcore/zipper/Printer.re +++ b/src/haz3lcore/zipper/Printer.re @@ -55,7 +55,10 @@ let to_rows = }; let measured = z => - z |> Zipper.seg_without_buffer |> Measured.of_segment(_, Id.Map.empty); + z + |> ProjectorPerform.Update.remove_all + |> Zipper.seg_without_buffer + |> Measured.of_segment(_, Id.Map.empty); let pretty_print = (~holes: option(string)=Some(""), z: Zipper.t): string => to_rows( @@ -78,15 +81,16 @@ let zipper_to_string = ) |> String.concat("\n"); -let to_string_selection = (editor: Editor.t): string => +let to_string_selection = (zipper: Zipper.t): string => { to_rows( - ~measured=measured(editor.state.zipper), + ~measured=measured(zipper), ~caret=None, ~indent=" ", ~holes=None, - ~segment=editor.state.zipper.selection.content, + ~segment=zipper.selection.content, ) |> String.concat("\n"); +}; let zipper_of_string = (~zipper_init=Zipper.init(), str: string): option(Zipper.t) => { diff --git a/src/haz3lcore/zipper/action/Action.re b/src/haz3lcore/zipper/action/Action.re index 85b24be4f1..6d9d3a36f5 100644 --- a/src/haz3lcore/zipper/action/Action.re +++ b/src/haz3lcore/zipper/action/Action.re @@ -97,7 +97,11 @@ module Failure = { | Cant_project | CantPaste | CantReparse - | CantAccept; + | CantAccept + | Cant_undo + | Cant_redo; + + exception Exception(t); }; module Result = { diff --git a/src/haz3lcore/zipper/action/Move.re b/src/haz3lcore/zipper/action/Move.re index afc46ca152..aa0f0d4a54 100644 --- a/src/haz3lcore/zipper/action/Move.re +++ b/src/haz3lcore/zipper/action/Move.re @@ -59,7 +59,13 @@ let neighbor_movability = (l, r); }; -module Make = (M: Editor.Meta.S) => { +module type S = { + let measured: Measured.t; + let term_ranges: TermRanges.t; + let col_target: int; +}; + +module Make = (M: S) => { let caret_point = Zipper.caret_point(M.measured); let pop_out = z => Some(z |> Zipper.set_caret(Outer)); diff --git a/src/haz3lcore/zipper/action/Perform.re b/src/haz3lcore/zipper/action/Perform.re index 5a3b90c245..89c9059ac1 100644 --- a/src/haz3lcore/zipper/action/Perform.re +++ b/src/haz3lcore/zipper/action/Perform.re @@ -15,18 +15,13 @@ let set_buffer = (info_map: Statics.Map.t, z: t): t => let go_z = ( - ~meta: option(Editor.Meta.t)=?, - ~settings: CoreSettings.t, + ~settings as _: CoreSettings.t, + statics: CachedStatics.t, a: Action.t, + module M: Move.S, z: Zipper.t, ) : Action.Result.t(Zipper.t) => { - let meta = - switch (meta) { - | Some(m) => m - | None => Editor.Meta.init(z, ~settings) - }; - module M = (val Editor.Meta.module_of_t(meta)); module Move = Move.Make(M); module Select = Select.Make(M); @@ -76,7 +71,7 @@ let go_z = * no additional effect, select the parent term instead */ let* (p, _, _) = Indicated.piece''(z); Piece.is_term(p) - ? Select.parent_of_indicated(z, meta.statics.info_map) + ? Select.parent_of_indicated(z, statics.info_map) : Select.nice_term(z); | _ => None }; @@ -103,7 +98,7 @@ let go_z = | None => Error(CantReparse) | Some(z) => Ok(z) } - | Buffer(Set(TyDi)) => Ok(set_buffer(meta.statics.info_map, z)) + | Buffer(Set(TyDi)) => Ok(set_buffer(statics.info_map, z)) | Buffer(Accept) => switch (buffer_accept(z)) { | None => Error(CantAccept) @@ -125,7 +120,7 @@ let go_z = | BindingSiteOfIndicatedVar => open OptUtil.Syntax; let* idx = Indicated.index(z); - let* ci = Id.Map.find_opt(idx, meta.statics.info_map); + let* ci = Id.Map.find_opt(idx, statics.info_map); let* binding_id = Info.get_binding_site(ci); Move.jump_to_id(z, binding_id); | TileId(id) => Move.jump_to_id(z, id) @@ -214,46 +209,3 @@ let go_z = |> Result.of_option(~error=Action.Failure.Cant_move) }; }; - -let go_history = - (~settings: CoreSettings.t, a: Action.t, ed: Editor.t) - : Action.Result.t(Editor.t) => { - open Result.Syntax; - /* This function records action history */ - let Editor.State.{zipper, meta} = ed.state; - let+ z = go_z(~settings, ~meta, a, zipper); - Editor.new_state(~settings, a, z, ed); -}; - -let go = - (~settings: CoreSettings.t, a: Action.t, ed: Editor.t) - : Action.Result.t(Editor.t) => - /* This function wraps assistant completions. If completions are enabled, - * then beginning any action (other than accepting a completion) clears - * the completion buffer before performing the action. Conversely, - * after any edit action, a new completion is set in the buffer */ - if (ed.read_only && Action.prevent_in_read_only_editor(a)) { - Ok(ed); - } else if (settings.assist && settings.statics) { - open Result.Syntax; - let ed = - a == Buffer(Accept) - ? ed - : ( - switch (go_history(~settings, Buffer(Clear), ed)) { - | Ok(ed) => ed - | Error(_) => ed - } - ); - let* ed = go_history(~settings, a, ed); - Action.is_edit(a) - ? { - switch (go_history(~settings, Buffer(Set(TyDi)), ed)) { - | Error(err) => Error(err) - | Ok(ed) => Ok(ed) - }; - } - : Ok(ed); - } else { - go_history(~settings, a, ed); - }; diff --git a/src/haz3lcore/zipper/action/ProjectorPerform.re b/src/haz3lcore/zipper/action/ProjectorPerform.re index a0996437bd..55a1d2e8f7 100644 --- a/src/haz3lcore/zipper/action/ProjectorPerform.re +++ b/src/haz3lcore/zipper/action/ProjectorPerform.re @@ -21,6 +21,15 @@ module Update = { }; }; + let init_from_str = (kind: t, syntax: syntax, model_str: string): syntax => { + let (module P) = to_module(kind); + switch (P.can_project(syntax) && minimum_projection_condition(syntax)) { + | false => syntax + | true => + Projector({id: Piece.id(syntax), kind, model: model_str, syntax}) + }; + }; + let add_projector = (kind: Base.kind, id: Id.t, syntax: syntax) => switch (syntax) { | Projector(pr) when Piece.id(syntax) == id => init(kind, pr.syntax) diff --git a/src/haz3lcore/zipper/action/Select.re b/src/haz3lcore/zipper/action/Select.re index dca2607863..f3d24af236 100644 --- a/src/haz3lcore/zipper/action/Select.re +++ b/src/haz3lcore/zipper/action/Select.re @@ -1,7 +1,7 @@ open Util; open OptUtil.Syntax; -module Make = (M: Editor.Meta.S) => { +module Make = (M: Move.S) => { module Move = Move.Make(M); let primary = (d: Direction.t, z: Zipper.t): option(Zipper.t) => diff --git a/src/haz3lcore/zipper/projectors/FoldProj.re b/src/haz3lcore/zipper/projectors/FoldProj.re index b21ab12721..8f9665dea6 100644 --- a/src/haz3lcore/zipper/projectors/FoldProj.re +++ b/src/haz3lcore/zipper/projectors/FoldProj.re @@ -3,20 +3,27 @@ open ProjectorBase; open Virtual_dom.Vdom; open Node; +[@deriving (show({with_path: false}), sexp, yojson)] +type t = { + [@default "⋱"] + text: string, +}; + module M: Projector = { [@deriving (show({with_path: false}), sexp, yojson)] - type model = unit; + type model = t; [@deriving (show({with_path: false}), sexp, yojson)] type action = unit; - let init = (); + let init = {text: "⋱"}; let can_project = _ => true; let can_focus = false; - let placeholder = (_, _) => Inline(2); - let update = (_, _) => (); - let view = (_, ~info as _, ~local as _, ~parent) => + let placeholder = (m, _) => + Inline(m.text == "⋱" ? 2 : m.text |> String.length); + let update = (m, _) => m; + let view = (m: model, ~info as _, ~local as _, ~parent) => div( ~attrs=[Attr.on_double_click(_ => parent(Remove))], - [text("⋱")], + [text(m.text)], ); let focus = _ => (); }; diff --git a/src/haz3lschool/Exercise.re b/src/haz3lschool/Exercise.re deleted file mode 100644 index 01050d5e7b..0000000000 --- a/src/haz3lschool/Exercise.re +++ /dev/null @@ -1,945 +0,0 @@ -open Util; -open Haz3lcore; - -module type ExerciseEnv = { - type node; - let default: node; - let output_header: string => string; -}; - -let output_header_grading = _module_name => - "module Exercise = GradePrelude.Exercise\n" ++ "let prompt = ()\n"; - -module F = (ExerciseEnv: ExerciseEnv) => { - [@deriving (show({with_path: false}), sexp, yojson)] - type wrong_impl('code) = { - impl: 'code, - hint: string, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type hidden_tests('code) = { - tests: 'code, - hints: list(string), - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type hint = string; - - [@deriving (show({with_path: false}), sexp, yojson)] - type syntax_test = (hint, SyntaxTest.predicate); - - [@deriving (show({with_path: false}), sexp, yojson)] - type syntax_tests = list(syntax_test); - - [@deriving (show({with_path: false}), sexp, yojson)] - type your_tests('code) = { - tests: 'code, - required: int, - provided: int, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type point_distribution = { - test_validation: int, - mutation_testing: int, - impl_grading: int, - }; - - let validate_point_distribution = - ({test_validation, mutation_testing, impl_grading}: point_distribution) => - test_validation + mutation_testing + impl_grading == 100 - ? () : failwith("Invalid point distribution in exercise."); - - [@deriving (show({with_path: false}), sexp, yojson)] - type p('code) = { - title: string, - version: int, - module_name: string, - prompt: - [@printer (fmt, _) => Format.pp_print_string(fmt, "prompt")] [@opaque] ExerciseEnv.node, - point_distribution, - prelude: 'code, - correct_impl: 'code, - your_tests: your_tests('code), - your_impl: 'code, - hidden_bugs: list(wrong_impl('code)), - hidden_tests: hidden_tests('code), - syntax_tests, - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type key = (string, int); - - let key_of = p => { - (p.title, p.version); - }; - - let find_key_opt = (key, specs: list(p('code))) => { - specs |> Util.ListUtil.findi_opt(spec => key_of(spec) == key); - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type pos = - | Prelude - | CorrectImpl - | YourTestsValidation - | YourTestsTesting - | YourImpl - | HiddenBugs(int) - | HiddenTests; - - [@deriving (show({with_path: false}), sexp, yojson)] - type spec = p(Zipper.t); - - [@deriving (show({with_path: false}), sexp, yojson)] - type transitionary_spec = p(CodeString.t); - - let map = (p: p('a), f: 'a => 'b): p('b) => { - { - title: p.title, - version: p.version, - module_name: p.module_name, - prompt: p.prompt, - point_distribution: p.point_distribution, - prelude: f(p.prelude), - correct_impl: f(p.correct_impl), - your_tests: { - tests: f(p.your_tests.tests), - required: p.your_tests.required, - provided: p.your_tests.provided, - }, - your_impl: f(p.your_impl), - hidden_bugs: - p.hidden_bugs - |> List.map(wrong_impl => { - { - impl: PersistentZipper.persist(wrong_impl.impl), - hint: wrong_impl.hint, - } - }), - hidden_tests: { - tests: PersistentZipper.persist(p.hidden_tests.tests), - hints: p.hidden_tests.hints, - }, - syntax_tests: p.syntax_tests, - }; - }; - - [@deriving (show({with_path: false}), sexp, yojson)] - type eds = p(Editor.t); - - [@deriving (show({with_path: false}), sexp, yojson)] - type state = { - pos, - eds, - }; - - let key_of_state = ({eds, _}) => key_of(eds); - - [@deriving (show({with_path: false}), sexp, yojson)] - type persistent_state = (pos, list((pos, PersistentZipper.t))); - - let editor_of_state: state => Editor.t = - ({pos, eds, _}) => - switch (pos) { - | Prelude => eds.prelude - | CorrectImpl => eds.correct_impl - | YourTestsValidation => eds.your_tests.tests - | YourTestsTesting => eds.your_tests.tests - | YourImpl => eds.your_impl - | HiddenBugs(i) => List.nth(eds.hidden_bugs, i).impl - | HiddenTests => eds.hidden_tests.tests - }; - - let put_editor = ({pos, eds, _} as state: state, editor: Editor.t) => - switch (pos) { - | Prelude => { - ...state, - eds: { - ...eds, - prelude: editor, - }, - } - | CorrectImpl => { - ...state, - eds: { - ...eds, - correct_impl: editor, - }, - } - | YourTestsValidation - | YourTestsTesting => { - ...state, - eds: { - ...eds, - your_tests: { - ...eds.your_tests, - tests: editor, - }, - }, - } - | YourImpl => { - ...state, - eds: { - ...eds, - your_impl: editor, - }, - } - | HiddenBugs(n) => { - ...state, - eds: { - ...eds, - hidden_bugs: - Util.ListUtil.put_nth( - n, - {...List.nth(eds.hidden_bugs, n), impl: editor}, - eds.hidden_bugs, - ), - }, - } - | HiddenTests => { - ...state, - eds: { - ...eds, - hidden_tests: { - ...eds.hidden_tests, - tests: editor, - }, - }, - } - }; - - let editors = ({eds, _}: state) => - [ - eds.prelude, - eds.correct_impl, - eds.your_tests.tests, - eds.your_tests.tests, - eds.your_impl, - ] - @ List.map(wrong_impl => wrong_impl.impl, eds.hidden_bugs) - @ [eds.hidden_tests.tests]; - - let editor_positions = ({eds, _}: state) => - [Prelude, CorrectImpl, YourTestsTesting, YourTestsValidation, YourImpl] - @ List.mapi((i, _) => HiddenBugs(i), eds.hidden_bugs) - @ [HiddenTests]; - - let positioned_editors = state => - List.combine(editor_positions(state), editors(state)); - - let idx_of_pos = (pos, p: p('code)) => - switch (pos) { - | Prelude => 0 - | CorrectImpl => 1 - | YourTestsTesting => 2 - | YourTestsValidation => 3 - | YourImpl => 4 - | HiddenBugs(i) => - if (i < List.length(p.hidden_bugs)) { - 5 + i; - } else { - failwith("invalid hidden bug index"); - } - | HiddenTests => 5 + List.length(p.hidden_bugs) - }; - - let pos_of_idx = (p: p('code), idx: int) => - switch (idx) { - | 0 => Prelude - | 1 => CorrectImpl - | 2 => YourTestsTesting - | 3 => YourTestsValidation - | 4 => YourImpl - | _ => - if (idx < 0) { - failwith("negative idx"); - } else if (idx < 5 + List.length(p.hidden_bugs)) { - HiddenBugs(idx - 5); - } else if (idx == 5 + List.length(p.hidden_bugs)) { - HiddenTests; - } else { - failwith("element idx"); - } - }; - - let switch_editor = (~pos, instructor_mode, ~exercise) => - if (!instructor_mode) { - switch (pos) { - | HiddenTests - | HiddenBugs(_) => exercise - | _ => {eds: exercise.eds, pos} - }; - } else { - {eds: exercise.eds, pos}; - }; - - let zipper_of_code = code => { - switch (Printer.zipper_of_string(code)) { - | None => failwith("Transition failed.") - | Some(zipper) => zipper - }; - }; - - let transition: transitionary_spec => spec = - ( - { - title, - version, - module_name, - prompt, - point_distribution, - prelude, - correct_impl, - your_tests, - your_impl, - hidden_bugs, - hidden_tests, - syntax_tests, - }, - ) => { - let prelude = zipper_of_code(prelude); - let correct_impl = zipper_of_code(correct_impl); - let your_tests = { - let tests = zipper_of_code(your_tests.tests); - {tests, required: your_tests.required, provided: your_tests.provided}; - }; - let your_impl = zipper_of_code(your_impl); - let hidden_bugs = - List.fold_left( - (acc, {impl, hint}) => { - let impl = zipper_of_code(impl); - acc @ [{impl, hint}]; - }, - [], - hidden_bugs, - ); - let hidden_tests = { - let {tests, hints} = hidden_tests; - let tests = zipper_of_code(tests); - {tests, hints}; - }; - { - title, - version, - module_name, - prompt, - point_distribution, - prelude, - correct_impl, - your_tests, - your_impl, - hidden_bugs, - hidden_tests, - syntax_tests, - }; - }; - - let eds_of_spec = - ( - { - title, - version, - module_name, - prompt, - point_distribution, - prelude, - correct_impl, - your_tests, - your_impl, - hidden_bugs, - hidden_tests, - syntax_tests, - }, - ~settings: CoreSettings.t, - ) - : eds => { - let editor_of_serialization = Editor.init(~settings); - let prelude = editor_of_serialization(prelude); - let correct_impl = editor_of_serialization(correct_impl); - let your_tests = { - let tests = editor_of_serialization(your_tests.tests); - {tests, required: your_tests.required, provided: your_tests.provided}; - }; - let your_impl = editor_of_serialization(your_impl); - let hidden_bugs = - hidden_bugs - |> List.map(({impl, hint}) => { - let impl = editor_of_serialization(impl); - {impl, hint}; - }); - let hidden_tests = { - let {tests, hints} = hidden_tests; - let tests = editor_of_serialization(tests); - {tests, hints}; - }; - { - title, - version, - module_name, - prompt, - point_distribution, - prelude, - correct_impl, - your_tests, - your_impl, - hidden_bugs, - hidden_tests, - syntax_tests, - }; - }; - - // - // Old version of above that did string-based parsing, may be useful - // for transitions between zipper data structure versions (TODO) - // - // let editor_of_code = (init_id, code) => - // switch (EditorUtil.editor_of_code(init_id, code)) { - // | None => failwith("Exercise error: invalid code") - // | Some(x) => x - // }; - // let eds_of_spec: spec => eds = - // ( - // { - // - // title, - // version, - // prompt, - // point_distribution, - // prelude, - // correct_impl, - // your_tests, - // your_impl, - // hidden_bugs, - // hidden_tests, - // }, - // ) => { - // let id = next_id; - // let (id, prelude) = editor_of_code(id, prelude); - // let (id, correct_impl) = editor_of_code(id, correct_impl); - // let (id, your_tests) = { - // let (id, tests) = editor_of_code(id, your_tests.tests); - // ( - // id, - // { - // tests, - // num_required: your_tests.num_required, - // minimum: your_tests.minimum, - // }, - // ); - // }; - // let (id, your_impl) = editor_of_code(id, your_impl); - // let (id, hidden_bugs) = - // List.fold_left( - // ((id, acc), {impl, hint}) => { - // let (id, impl) = editor_of_code(id, impl); - // (id, acc @ [{impl, hint}]); - // }, - // (id, []), - // hidden_bugs, - // ); - // let (id, hidden_tests) = { - // let {tests, hints} = hidden_tests; - // let (id, tests) = editor_of_code(id, tests); - // (id, {tests, hints}); - // }; - // { - // next_id: id, - // title, - // version, - // prompt, - // point_distribution, - // prelude, - // correct_impl, - // your_tests, - // your_impl, - // hidden_bugs, - // hidden_tests, - // }; - // }; - - let set_instructor_mode = ({eds, _} as state: state, new_mode: bool) => { - ...state, - eds: { - ...eds, - prelude: Editor.set_read_only(eds.prelude, !new_mode), - }, - }; - - let visible_in = (pos, ~instructor_mode) => { - switch (pos) { - | Prelude => instructor_mode - | CorrectImpl => instructor_mode - | YourTestsValidation => true - | YourTestsTesting => false - | YourImpl => true - | HiddenBugs(_) => instructor_mode - | HiddenTests => instructor_mode - }; - }; - - let state_of_spec = - (spec, ~instructor_mode: bool, ~settings: CoreSettings.t): state => { - let eds = eds_of_spec(~settings, spec); - set_instructor_mode({pos: YourImpl, eds}, instructor_mode); - }; - - let persistent_state_of_state = - ({pos, _} as state: state, ~instructor_mode: bool) => { - let zippers = - positioned_editors(state) - |> List.filter(((pos, _)) => visible_in(pos, ~instructor_mode)) - |> List.map(((pos, editor)) => { - (pos, PersistentZipper.persist(Editor.(editor.state.zipper))) - }); - (pos, zippers); - }; - - let unpersist_state = - ( - (pos, positioned_zippers): persistent_state, - ~spec: spec, - ~instructor_mode: bool, - ~settings: CoreSettings.t, - ) - : state => { - let lookup = (pos, default) => - if (visible_in(pos, ~instructor_mode)) { - let persisted_zipper = List.assoc(pos, positioned_zippers); - let zipper = PersistentZipper.unpersist(persisted_zipper); - Editor.init(zipper, ~settings); - } else { - Editor.init(default, ~settings); - }; - let prelude = lookup(Prelude, spec.prelude); - let correct_impl = lookup(CorrectImpl, spec.correct_impl); - let your_tests_tests = lookup(YourTestsValidation, spec.your_tests.tests); - let your_impl = lookup(YourImpl, spec.your_impl); - let (_, hidden_bugs) = - List.fold_left( - ((i, hidden_bugs: list(wrong_impl(Editor.t))), {impl, hint}) => { - let impl = lookup(HiddenBugs(i), impl); - (i + 1, hidden_bugs @ [{impl, hint}]); - }, - (0, []), - spec.hidden_bugs, - ); - let hidden_tests_tests = lookup(HiddenTests, spec.hidden_tests.tests); - - set_instructor_mode( - { - pos, - eds: { - title: spec.title, - version: spec.version, - module_name: spec.module_name, - prompt: spec.prompt, - point_distribution: spec.point_distribution, - prelude, - correct_impl, - your_tests: { - tests: your_tests_tests, - required: spec.your_tests.required, - provided: spec.your_tests.provided, - }, - your_impl, - hidden_bugs, - hidden_tests: { - tests: hidden_tests_tests, - hints: spec.hidden_tests.hints, - }, - syntax_tests: spec.syntax_tests, - }, - }, - instructor_mode, - ); - }; - - // # Stitching - - type stitched('a) = { - test_validation: 'a, // prelude + correct_impl + your_tests - user_impl: 'a, // prelude + your_impl - user_tests: 'a, // prelude + your_impl + your_tests - prelude: 'a, // prelude - instructor: 'a, // prelude + correct_impl + hidden_tests.tests // TODO only needs to run in instructor mode - hidden_bugs: list('a), // prelude + hidden_bugs[i].impl + your_tests, - hidden_tests: 'a, - }; - - let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => { - term: - Filter( - Filter({ - act: FilterAction.(act, One), - pat: { - term: Constructor("$e", Unknown(Internal) |> Typ.temp), - copied: false, - ids: [Id.mk()], - }, - }), - term, - ), - copied: false, - ids: [Id.mk()], - }; - - let term_of = (editor: Editor.t): UExp.t => - MakeTerm.from_zip_for_sem(editor.state.zipper).term; - - let stitch3 = (ed1: Editor.t, ed2: Editor.t, ed3: Editor.t) => - EditorUtil.append_exp( - EditorUtil.append_exp(term_of(ed1), term_of(ed2)), - term_of(ed3), - ); - - let stitch_term = ({eds, _}: state): stitched(UExp.t) => { - let instructor = - stitch3(eds.prelude, eds.correct_impl, eds.hidden_tests.tests); - let user_impl_term = { - let your_impl_term = - eds.your_impl |> term_of |> wrap_filter(FilterAction.Step); - let prelude_term = - eds.prelude |> term_of |> wrap_filter(FilterAction.Eval); - EditorUtil.append_exp(prelude_term, your_impl_term); - }; - let test_validation_term = - stitch3(eds.prelude, eds.correct_impl, eds.your_tests.tests); - let user_tests_term = - EditorUtil.append_exp(user_impl_term, term_of(eds.your_tests.tests)); - let hidden_tests_term = - EditorUtil.append_exp(user_impl_term, term_of(eds.hidden_tests.tests)); - { - test_validation: test_validation_term, - user_impl: user_impl_term, - user_tests: user_tests_term, - // instructor works here as long as you don't shadow anything in the prelude - prelude: instructor, - instructor, - hidden_bugs: - List.map( - (t): UExp.t => stitch3(eds.prelude, t.impl, eds.your_tests.tests), - eds.hidden_bugs, - ), - hidden_tests: hidden_tests_term, - }; - }; - let stitch_term = Core.Memo.general(stitch_term); - - type stitched_statics = stitched(Editor.CachedStatics.t); - - /* Multiple stitchings are needed for each exercise - (see comments in the stitched type above) - - Stitching is necessary to concatenate terms - from different editors, which are then typechecked. */ - let stitch_static = - (settings: CoreSettings.t, t: stitched(UExp.t)): stitched_statics => { - let mk = (term: UExp.t): Editor.CachedStatics.t => { - let info_map = Statics.mk(settings, Builtins.ctx_init, term); - {term, error_ids: Statics.Map.error_ids(info_map), info_map}; - }; - let instructor = mk(t.instructor); - { - test_validation: mk(t.test_validation), - user_impl: mk(t.user_impl), - user_tests: mk(t.user_tests), - prelude: instructor, // works as long as you don't shadow anything in the prelude - instructor, - hidden_bugs: List.map(mk, t.hidden_bugs), - hidden_tests: mk(t.hidden_tests), - }; - }; - - let stitch_static = Core.Memo.general(stitch_static); - - let prelude_key = "prelude"; - let test_validation_key = "test_validation"; - let user_impl_key = "user_impl"; - let user_tests_key = "user_tests"; - let instructor_key = "instructor"; - let hidden_bugs_key = n => "hidden_bugs_" ++ string_of_int(n); - let hidden_tests_key = "hidden_tests"; - - let key_for_statics = (state: state): string => - switch (state.pos) { - | Prelude => prelude_key - | CorrectImpl => instructor_key - | YourTestsValidation => test_validation_key - | YourTestsTesting => user_tests_key - | YourImpl => user_impl_key - | HiddenBugs(idx) => hidden_bugs_key(idx) - | HiddenTests => hidden_tests_key - }; - - let spliced_elabs = - (settings: CoreSettings.t, state: state) - : list((ModelResults.key, Elaborator.Elaboration.t)) => { - let { - test_validation, - user_impl, - user_tests, - prelude: _, - instructor, - hidden_bugs, - hidden_tests, - } = - stitch_static(settings, stitch_term(state)); - let elab = (s: Editor.CachedStatics.t): Elaborator.Elaboration.t => { - d: Interface.elaborate(~settings, s.info_map, s.term), - }; - [ - (test_validation_key, elab(test_validation)), - (user_impl_key, elab(user_impl)), - (user_tests_key, elab(user_tests)), - (instructor_key, elab(instructor)), - (hidden_tests_key, elab(hidden_tests)), - ] - @ ( - hidden_bugs - |> List.mapi((n, hidden_bug: Editor.CachedStatics.t) => - (hidden_bugs_key(n), elab(hidden_bug)) - ) - ); - }; - - module DynamicsItem = { - type t = { - statics: Editor.CachedStatics.t, - result: ModelResult.t, - }; - let empty: t = {statics: Editor.CachedStatics.empty, result: NoElab}; - let statics_only = (statics: Editor.CachedStatics.t): t => { - statics, - result: NoElab, - }; - }; - - let statics_of_stiched_dynamics = - (state: state, s: stitched(DynamicsItem.t)): Editor.CachedStatics.t => - switch (state.pos) { - | Prelude => s.prelude.statics - | CorrectImpl => s.instructor.statics - | YourTestsValidation => s.test_validation.statics - | YourTestsTesting => s.user_tests.statics - | YourImpl => s.user_impl.statics - | HiddenBugs(idx) => List.nth(s.hidden_bugs, idx).statics - | HiddenTests => s.hidden_tests.statics - }; - - /* Given the evaluation results, collects the - relevant information for producing dynamic - feedback*/ - let stitch_dynamic = - ( - settings: CoreSettings.t, - state: state, - results: option(ModelResults.t), - ) - : stitched(DynamicsItem.t) => { - let { - test_validation, - user_impl, - user_tests, - prelude, - instructor, - hidden_bugs, - hidden_tests, - } = - stitch_static(settings, stitch_term(state)); - let result_of = key => - switch (results) { - | None => ModelResult.NoElab - | Some(results) => - ModelResults.lookup(results, key) - |> Option.value(~default=ModelResult.NoElab) - }; - - let test_validation = - DynamicsItem.{ - statics: test_validation, - result: result_of(test_validation_key), - }; - - let user_impl = - DynamicsItem.{statics: user_impl, result: result_of(user_impl_key)}; - - let user_tests = - DynamicsItem.{statics: user_tests, result: result_of(user_tests_key)}; - let prelude = DynamicsItem.{statics: prelude, result: NoElab}; - let instructor = - DynamicsItem.{statics: instructor, result: result_of(instructor_key)}; - let hidden_bugs = - List.mapi( - (n, statics: Editor.CachedStatics.t) => - DynamicsItem.{statics, result: result_of(hidden_bugs_key(n))}, - hidden_bugs, - ); - let hidden_tests = - DynamicsItem.{ - statics: hidden_tests, - result: result_of(hidden_tests_key), - }; - { - test_validation, - user_impl, - user_tests, - instructor, - prelude, - hidden_bugs, - hidden_tests, - }; - }; - - let stitch_dynamic = - ( - settings: CoreSettings.t, - state: state, - results: option(ModelResults.t), - ) - : stitched(DynamicsItem.t) => - if (settings.statics && settings.dynamics) { - stitch_dynamic(settings, state, results); - } else if (settings.statics) { - let t = stitch_static(settings, stitch_term(state)); - { - test_validation: DynamicsItem.statics_only(t.test_validation), - user_impl: DynamicsItem.statics_only(t.user_impl), - user_tests: DynamicsItem.statics_only(t.user_tests), - instructor: DynamicsItem.statics_only(t.instructor), - prelude: DynamicsItem.statics_only(t.prelude), - hidden_bugs: List.map(DynamicsItem.statics_only, t.hidden_bugs), - hidden_tests: DynamicsItem.statics_only(t.hidden_tests), - }; - } else { - { - test_validation: DynamicsItem.empty, - user_impl: DynamicsItem.empty, - user_tests: DynamicsItem.empty, - instructor: DynamicsItem.empty, - prelude: DynamicsItem.empty, - hidden_bugs: - List.init(List.length(state.eds.hidden_bugs), _ => - DynamicsItem.empty - ), - hidden_tests: DynamicsItem.empty, - }; - }; - let stitch_dynamic = Core.Memo.general(stitch_dynamic); - - // Module Export - - let editor_pp = (fmt, editor: Editor.t) => { - let zipper = editor.state.zipper; - let serialization = Zipper.show(zipper); - // let string_literal = "\"" ++ String.escaped(serialization) ++ "\""; - Format.pp_print_string(fmt, serialization); - }; - - let export_module = (module_name, {eds, _}: state) => { - let prefix = - "let prompt = " - ++ module_name - ++ "_prompt.prompt\n" - ++ "let exercise: Exercise.spec = "; - let record = show_p(editor_pp, eds); - let data = prefix ++ record ++ "\n"; - data; - }; - - let transitionary_editor_pp = (fmt, editor: Editor.t) => { - let zipper = editor.state.zipper; - let code = Printer.to_string_basic(zipper); - Format.pp_print_string(fmt, "\"" ++ String.escaped(code) ++ "\""); - }; - - let export_transitionary_module = (module_name, {eds, _}: state) => { - let prefix = - "let prompt = " - ++ module_name - ++ "_prompt.prompt\n" - ++ "let exercise: Exercise.spec = Exercise.transition("; - let record = show_p(transitionary_editor_pp, eds); - let data = prefix ++ record ++ ")\n"; - data; - }; - - let export_grading_module = (module_name, {eds, _}: state) => { - let header = output_header_grading(module_name); - let prefix = "let exercise: Exercise.spec = "; - let record = show_p(editor_pp, eds); - let data = header ++ prefix ++ record ++ "\n"; - data; - }; - - let blank_spec = - ( - ~title, - ~module_name, - ~point_distribution, - ~required_tests, - ~provided_tests, - ~num_wrong_impls, - ) => { - let prelude = Zipper.next_blank(); - let correct_impl = Zipper.next_blank(); - let your_tests_tests = Zipper.next_blank(); - let your_impl = Zipper.next_blank(); - let hidden_bugs = - List.init( - num_wrong_impls, - i => { - let zipper = Zipper.next_blank(); - {impl: zipper, hint: "TODO: hint " ++ string_of_int(i)}; - }, - ); - let hidden_tests_tests = Zipper.next_blank(); - { - title, - version: 1, - module_name, - prompt: ExerciseEnv.default, - point_distribution, - prelude, - correct_impl, - your_tests: { - tests: your_tests_tests, - required: required_tests, - provided: provided_tests, - }, - your_impl, - hidden_bugs, - hidden_tests: { - tests: hidden_tests_tests, - hints: [], - }, - syntax_tests: [], - }; - }; - - // From Store - - [@deriving (show({with_path: false}), sexp, yojson)] - type exercise_export = { - cur_exercise: key, - exercise_data: list((key, persistent_state)), - }; - - let serialize_exercise = (exercise, ~instructor_mode) => { - persistent_state_of_state(exercise, ~instructor_mode) - |> sexp_of_persistent_state - |> Sexplib.Sexp.to_string; - }; - - let deserialize_exercise = (data, ~spec, ~instructor_mode) => { - data - |> Sexplib.Sexp.of_string - |> persistent_state_of_sexp - |> unpersist_state(~spec, ~instructor_mode); - }; - - let deserialize_exercise_export = data => { - data |> Sexplib.Sexp.of_string |> exercise_export_of_sexp; - }; -}; diff --git a/src/haz3lschool/GradePrelude.re b/src/haz3lschool/GradePrelude.re deleted file mode 100644 index a45b34fa15..0000000000 --- a/src/haz3lschool/GradePrelude.re +++ /dev/null @@ -1,9 +0,0 @@ -module ExerciseEnv = { - type node = unit; - let default = (); - let output_header = Exercise.output_header_grading; -}; - -module Exercise = Exercise.F(ExerciseEnv); - -module Grading = Grading.F(ExerciseEnv); diff --git a/src/haz3lschool/Grading.re b/src/haz3lschool/Grading.re deleted file mode 100644 index 9e0f577772..0000000000 --- a/src/haz3lschool/Grading.re +++ /dev/null @@ -1,310 +0,0 @@ -open Haz3lcore; -open Util; - -module F = (ExerciseEnv: Exercise.ExerciseEnv) => { - open Exercise.F(ExerciseEnv); - - [@deriving (show({with_path: false}), sexp, yojson)] - type percentage = float; - [@deriving (show({with_path: false}), sexp, yojson)] - type points = float; - [@deriving (show({with_path: false}), sexp, yojson)] - type score = (points, points); - - let score_of_percent = (percent, max_points) => { - let max_points = float_of_int(max_points); - (percent *. max_points, max_points); - }; - - module TestValidationReport = { - type t = { - test_results: option(TestResults.t), - required: int, - provided: int, - }; - - let mk = (eds: eds, test_results: option(TestResults.t)) => { - { - test_results, - required: eds.your_tests.required, - provided: eds.your_tests.provided, - }; - }; - - let percentage = (report: t): percentage => { - switch (report.test_results) { - | None => 0.0 - | Some(test_results) => - let num_tests = float_of_int(test_results.total); - let required = float_of_int(report.required); - let provided = float_of_int(report.provided); - let num_passing = float_of_int(test_results.passing); - - required -. provided <= 0.0 || num_tests <= 0.0 - ? 0.0 - : num_passing - /. num_tests - *. ( - Float.max( - 0., - Float.min(num_tests -. provided, required -. provided), - ) - /. (required -. provided) - ); - }; - }; - - let test_summary_str = (test_results: TestResults.t) => { - TestResults.result_summary_str( - ~n=test_results.total, - ~p=test_results.failing, - ~q=test_results.unfinished, - ~n_str="test", - ~ns_str="tests", - ~p_str="failing", - ~q_str="indeterminate", - ~r_str="valid", - ); - }; - }; - - module MutationTestingReport = { - type t = {results: list((TestStatus.t, string))}; - - let hidden_bug_status = - ( - test_validation_data: DynamicsItem.t, - hidden_bug_data: DynamicsItem.t, - ) - : TestStatus.t => { - switch ( - ModelResult.test_results(test_validation_data.result), - ModelResult.test_results(hidden_bug_data.result), - ) { - | (None, _) - | (_, None) => Indet - | (Some(test_validation_data), Some(hidden_bug_data)) => - let validation_test_map = test_validation_data.test_map; - let hidden_bug_test_map = hidden_bug_data.test_map; - - let found = - hidden_bug_test_map - |> List.find_opt(((id, instance_reports)) => { - let status = TestMap.joint_status(instance_reports); - switch (status) { - | TestStatus.Pass - | TestStatus.Indet => false - | TestStatus.Fail => - let validation_test_reports = - validation_test_map |> TestMap.lookup(id); - switch (validation_test_reports) { - | None => false - | Some(reports) => - let status = TestMap.joint_status(reports); - switch (status) { - | TestStatus.Pass => true - | TestStatus.Fail - | TestStatus.Indet => false - }; - }; - }; - }); - switch (found) { - | None => Fail - | Some(_) => Pass - }; - }; - }; // for each hidden bug - // in the test results data, find a test ID that passes test validation but fails against - - let mk = - ( - ~test_validation: DynamicsItem.t, - ~hidden_bugs_state: list(wrong_impl(Editor.t)), - ~hidden_bugs: list(DynamicsItem.t), - ) - : t => { - let results = - List.map(hidden_bug_status(test_validation), hidden_bugs); - let hints = - List.map( - (wrong_impl: wrong_impl(Editor.t)) => wrong_impl.hint, - hidden_bugs_state, - ); - let results = List.combine(results, hints); - {results: results}; - }; - - let percentage = (report: t): percentage => { - let results = report.results; - let num_wrong_impls = List.length(results); - let num_passed = - results - |> List.find_all(((status, _)) => status == TestStatus.Pass) - |> List.length; - switch (num_wrong_impls) { - | 0 => 1.0 - | _ => float_of_int(num_passed) /. float_of_int(num_wrong_impls) - }; - }; - - // TODO move to separate module - - let summary_str = (~total, ~found): string => { - TestResults.result_summary_str( - ~n=total, - ~p=found, - ~q=0, - ~n_str="bug", - ~ns_str="bugs", - ~p_str="exposed", - ~q_str="", - ~r_str="unrevealed", - ); - }; - }; - - module SyntaxReport = { - type t = { - hinted_results: list((bool, hint)), - percentage, - }; - - let mk = (~your_impl: Editor.t, ~tests: syntax_tests): t => { - let user_impl_term = - MakeTerm.from_zip_for_sem(your_impl.state.zipper).term; - - let predicates = - List.map(((_, p)) => SyntaxTest.predicate_fn(p), tests); - let hints = List.map(((h, _)) => h, tests); - let syntax_results = SyntaxTest.check(user_impl_term, predicates); - - { - hinted_results: - List.map2((r, h) => (r, h), syntax_results.results, hints), - percentage: syntax_results.percentage, - }; - }; - }; - - module ImplGradingReport = { - type t = { - hints: list(string), - test_results: option(TestResults.t), - hinted_results: list((TestStatus.t, string)), - }; - - let mk = (~hints: list(string), ~test_results: option(TestResults.t)): t => { - let hinted_results = - switch (test_results) { - | Some(test_results) => - let statuses = test_results.statuses; - Util.ListUtil.zip_defaults( - statuses, - hints, - Haz3lcore.TestStatus.Indet, - "No hint available.", - ); - - | None => - Util.ListUtil.zip_defaults( - [], - hints, - Haz3lcore.TestStatus.Indet, - "Exercise configuration error: Hint without a test.", - ) - }; - {hints, test_results, hinted_results}; - }; - - let total = (report: t) => List.length(report.hinted_results); - let num_passed = (report: t) => { - report.hinted_results - |> List.find_all(((status, _)) => status == TestStatus.Pass) - |> List.length; - }; - - let percentage = (report: t, syntax_report: SyntaxReport.t): percentage => { - syntax_report.percentage - *. (float_of_int(num_passed(report)) /. float_of_int(total(report))); - }; - - let test_summary_str = (test_results: TestResults.t) => { - TestResults.result_summary_str( - ~n=test_results.total, - ~p=test_results.failing, - ~q=test_results.unfinished, - ~n_str="test", - ~ns_str="tests", - ~p_str="failing", - ~q_str="indeterminate", - ~r_str="valid", - ); - }; - }; - - module GradingReport = { - type t = { - point_distribution, - test_validation_report: TestValidationReport.t, - mutation_testing_report: MutationTestingReport.t, - syntax_report: SyntaxReport.t, - impl_grading_report: ImplGradingReport.t, - }; - - let mk = (eds: eds, ~stitched_dynamics: stitched(DynamicsItem.t)) => { - point_distribution: eds.point_distribution, - test_validation_report: - TestValidationReport.mk( - eds, - ModelResult.test_results(stitched_dynamics.test_validation.result), - ), - mutation_testing_report: - MutationTestingReport.mk( - ~test_validation=stitched_dynamics.test_validation, - ~hidden_bugs_state=eds.hidden_bugs, - ~hidden_bugs=stitched_dynamics.hidden_bugs, - ), - syntax_report: - SyntaxReport.mk(~your_impl=eds.your_impl, ~tests=eds.syntax_tests), - impl_grading_report: - ImplGradingReport.mk( - ~hints=eds.hidden_tests.hints, - ~test_results= - ModelResult.test_results(stitched_dynamics.hidden_tests.result), - ), - }; - - let overall_score = - ( - { - point_distribution, - test_validation_report, - mutation_testing_report, - syntax_report, - impl_grading_report, - _, - }: t, - ) - : score => { - let (tv_points, tv_max) = - score_of_percent( - TestValidationReport.percentage(test_validation_report), - point_distribution.test_validation, - ); - let (mt_points, mt_max) = - score_of_percent( - MutationTestingReport.percentage(mutation_testing_report), - point_distribution.mutation_testing, - ); - let (ig_points, ig_max) = - score_of_percent( - ImplGradingReport.percentage(impl_grading_report, syntax_report), - point_distribution.impl_grading, - ); - let total_points = tv_points +. mt_points +. ig_points; - let max_points = tv_max +. mt_max +. ig_max; - (total_points, max_points); - }; - }; -}; diff --git a/src/haz3lschool/dune b/src/haz3lschool/dune deleted file mode 100644 index a9f7575c78..0000000000 --- a/src/haz3lschool/dune +++ /dev/null @@ -1,23 +0,0 @@ -(include_subdirs unqualified) - -(library - (name haz3lschool) - (modules (:standard) \ Gradescope) - (libraries util ppx_yojson_conv.expander haz3lcore pretty) - (preprocess - (pps ppx_yojson_conv ppx_let ppx_sexp_conv ppx_deriving.show))) - -(executable - (name gradescope) - (modules Gradescope) - (libraries ppx_yojson_conv.expander haz3lcore haz3lschool) - (preprocess - (pps ppx_yojson_conv ppx_let ppx_sexp_conv ppx_deriving.show))) - -(env - (dev - (js_of_ocaml - (flags :standard --debuginfo --noinline --dynlink --linkall --sourcemap))) - (release - (js_of_ocaml - (flags :standard)))) diff --git a/src/haz3lweb/Editors.re b/src/haz3lweb/Editors.re deleted file mode 100644 index f8fa4e0b06..0000000000 --- a/src/haz3lweb/Editors.re +++ /dev/null @@ -1,170 +0,0 @@ -open Util; -open Haz3lcore; - -[@deriving (show({with_path: false}), sexp, yojson)] -type scratch = (int, list(ScratchSlide.state)); - -[@deriving (show({with_path: false}), sexp, yojson)] -type examples = (string, list((string, ScratchSlide.state))); - -[@deriving (show({with_path: false}), sexp, yojson)] -type exercises = (int, list(Exercise.spec), Exercise.state); - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - | Scratch(int, list(ScratchSlide.state)) - | Documentation(string, list((string, ScratchSlide.state))) - | Exercises(int, list(Exercise.spec), Exercise.state); - -let get_editor = (editors: t): Editor.t => - switch (editors) { - | Scratch(n, slides) => - assert(n < List.length(slides)); - List.nth(slides, n); - | Documentation(name, slides) => - assert(List.mem_assoc(name, slides)); - List.assoc(name, slides); - | Exercises(_, _, exercise) => Exercise.editor_of_state(exercise) - }; - -let put_editor = (ed: Editor.t, eds: t): t => - switch (eds) { - | Scratch(n, slides) => - assert(n < List.length(slides)); - Scratch(n, Util.ListUtil.put_nth(n, ed, slides)); - | Documentation(name, slides) => - assert(List.mem_assoc(name, slides)); - Documentation(name, slides |> ListUtil.update_assoc((name, ed))); - | Exercises(n, specs, exercise) => - Exercises(n, specs, Exercise.put_editor(exercise, ed)) - }; - -let update = (f: Editor.t => Editor.t, editors: t): t => - editors |> get_editor |> f |> put_editor(_, editors); - -let update_opt = (editors: t, f: Editor.t => option(Editor.t)): option(t) => - editors |> get_editor |> f |> Option.map(put_editor(_, editors)); - -let perform_action = - (~settings: CoreSettings.t, editors: t, a: Action.t) - : UpdateAction.Result.t(t) => { - let settings = - switch (editors) { - | Exercises(_) => - /* If we're in exercises mode, statics is calculated externally, - * so we set it to off here to disable internal calculation*/ - CoreSettings.on - | _ => settings - }; - switch (Perform.go(~settings, a, get_editor(editors))) { - | Error(err) => Error(FailedToPerform(err)) - | Ok(ed) => Ok(put_editor(ed, editors)) - }; -}; - -let update_current_editor_statics = settings => - update(Editor.update_statics(~settings)); - -let get_ctx_init = (~settings as _: Settings.t, editors: t): Ctx.t => - switch (editors) { - | Scratch(_) - | Exercises(_) - | Documentation(_) => Builtins.ctx_init - }; - -let get_env_init = (~settings as _: Settings.t, editors: t): Environment.t => - switch (editors) { - | Scratch(_) - | Exercises(_) - | Documentation(_) => Builtins.env_init - }; - -/* Each mode (e.g. Scratch, School) requires - elaborating on some number of expressions - that are spliced together from the editors - in the mode. Each elaborated expression - is given a key for later lookup by the mode. - - Used in the Update module */ -let get_spliced_elabs = - (~settings: CoreSettings.t, editors: t) - : list((ModelResults.key, Elaborator.Elaboration.t)) => - switch (editors) { - | Scratch(idx, _) => - let key = ScratchSlide.scratch_key(idx |> string_of_int); - let statics = get_editor(editors).state.meta.statics; - let d = Interface.elaborate(~settings, statics.info_map, statics.term); - [(key, {d: d})]; - | Documentation(name, _) => - let key = ScratchSlide.scratch_key(name); - let statics = get_editor(editors).state.meta.statics; - let d = Interface.elaborate(~settings, statics.info_map, statics.term); - [(key, {d: d})]; - | Exercises(_, _, exercise) => Exercise.spliced_elabs(settings, exercise) - }; - -let set_instructor_mode = (editors: t, instructor_mode: bool): t => - switch (editors) { - | Scratch(_) - | Documentation(_) => editors - | Exercises(n, specs, exercise) => - Exercises( - n, - specs, - Exercise.set_instructor_mode(exercise, instructor_mode), - ) - }; - -let reset_nth_slide = (~settings: CoreSettings.t, n, slides): list(Editor.t) => { - let (_, init_editors, _) = Init.startup.scratch; - let data = List.nth(init_editors, n); - let init_nth = ScratchSlide.unpersist(~settings, data); - Util.ListUtil.put_nth(n, init_nth, slides); -}; - -let reset_named_slide = - (~settings: CoreSettings.t, name, slides): list((string, Editor.t)) => { - let (_, init_editors, _) = Init.startup.documentation; - let data = List.assoc(name, init_editors); - let init_name = ScratchSlide.unpersist(~settings, data); - slides |> List.remove_assoc(name) |> List.cons((name, init_name)); -}; - -let reset_current = - (editors: t, ~settings: CoreSettings.t, ~instructor_mode: bool): t => - switch (editors) { - | Scratch(n, slides) => Scratch(n, reset_nth_slide(~settings, n, slides)) - | Documentation(name, slides) => - Documentation(name, reset_named_slide(~settings, name, slides)) - | Exercises(n, specs, _) => - Exercises( - n, - specs, - List.nth(specs, n) - |> Exercise.state_of_spec(~settings, ~instructor_mode), - ) - }; - -let import_current = (~settings, editors: t, data: option(string)): t => - switch (editors) { - | Documentation(_) - | Exercises(_) => failwith("impossible") - | Scratch(idx, slides) => - switch (data) { - | None => editors - | Some(data) => - let state = ScratchSlide.import(~settings, data); - let slides = Util.ListUtil.put_nth(idx, state, slides); - Scratch(idx, slides); - } - }; - -let switch_example_slide = (editors: t, name: string): option(t) => - switch (editors) { - | Scratch(_) - | Exercises(_) => None - | Documentation(cur, slides) - when !List.mem_assoc(name, slides) || cur == name => - None - | Documentation(_, slides) => Some(Documentation(name, slides)) - }; diff --git a/src/haz3lweb/Exercise.re b/src/haz3lweb/Exercise.re deleted file mode 100644 index ec187c90db..0000000000 --- a/src/haz3lweb/Exercise.re +++ /dev/null @@ -1,10 +0,0 @@ -open Virtual_dom.Vdom; - -module ExerciseEnv = { - type node = Node.t; - let default = Node.text("TODO: prompt"); - let output_header = module_name => - "let prompt = " ++ module_name ++ "_prompt.prompt\n"; -}; - -include Haz3lschool.Exercise.F(ExerciseEnv); diff --git a/src/haz3lweb/Export.re b/src/haz3lweb/Export.re index 9c9f709fa9..4d367350ea 100644 --- a/src/haz3lweb/Export.re +++ b/src/haz3lweb/Export.re @@ -19,26 +19,21 @@ type all_f22 = { log: string, }; -let mk_all = (~instructor_mode, ~log) => { - let settings = Store.Settings.export(); - let explainThisModel = Store.ExplainThisModel.export(); - let settings_obj = Store.Settings.load(); - let scratch = Store.Scratch.export(~settings=settings_obj.core); - let documentation = Store.Documentation.export(~settings=settings_obj.core); +let mk_all = (~core_settings, ~instructor_mode, ~log) => { + let settings = Settings.Store.export(); + let explainThisModel = ExplainThisModel.Store.export(); + let scratch = ScratchMode.Store.export(); + let documentation = ScratchMode.StoreDocumentation.export(); let exercise = - Store.Exercise.export( - ~settings=settings_obj.core, - ~specs=ExerciseSettings.exercises, - ~instructor_mode, - ); + ExercisesMode.Store.export(~settings=core_settings, ~instructor_mode); {settings, explainThisModel, scratch, documentation, exercise, log}; }; -let export_all = (~instructor_mode, ~log) => { - mk_all(~instructor_mode, ~log) |> yojson_of_all; +let export_all = (~settings, ~instructor_mode, ~log) => { + mk_all(~core_settings=settings, ~instructor_mode, ~log) |> yojson_of_all; }; -let import_all = (data, ~specs) => { +let import_all = (~import_log: string => unit, data, ~specs) => { let all = try(data |> Yojson.Safe.from_string |> all_of_yojson) { | _ => @@ -52,15 +47,31 @@ let import_all = (data, ~specs) => { explainThisModel: "", }; }; - let settings = Store.Settings.import(all.settings); - Store.ExplainThisModel.import(all.explainThisModel); + Settings.Store.import(all.settings); + let settings = Settings.Store.load(); + ExplainThisModel.Store.import(all.explainThisModel); let instructor_mode = settings.instructor_mode; - Store.Scratch.import(~settings=settings.core, all.scratch); - Store.Exercise.import( + ScratchMode.Store.import(all.scratch); + ExercisesMode.Store.import( ~settings=settings.core, all.exercise, ~specs, ~instructor_mode, ); - Log.import(all.log); + import_log(all.log); +}; + +let export_persistent = () => { + let data: PersistentData.t = { + documentation: ScratchMode.StoreDocumentation.load(), + scratch: ScratchMode.Store.load(), + }; + let contents = + "let startup : PersistentData.t = " ++ PersistentData.show(data); + JsUtil.download_string_file( + ~filename="Init.ml", + ~content_type="text/plain", + ~contents, + ); + print_endline("INFO: Persistent data exported to Init.ml"); }; diff --git a/src/haz3lweb/Init.ml b/src/haz3lweb/Init.ml index c3d2de0aba..e8ee282e9d 100644 --- a/src/haz3lweb/Init.ml +++ b/src/haz3lweb/Init.ml @@ -1,36 +1,5 @@ let startup : PersistentData.t = { - settings = - { - captions = true; - secondary_icons = false; - core = - { - statics = true; - elaborate = false; - assist = true; - dynamics = true; - evaluation = - { - show_case_clauses = true; - show_fn_bodies = false; - show_fixpoints = false; - show_casts = false; - show_lookup_steps = false; - show_stepper_filters = false; - stepper_history = false; - show_settings = false; - show_hidden_steps = false; - }; - }; - async_evaluation = false; - context_inspector = false; - instructor_mode = true; - benchmark = false; - explainThis = - { show = true; show_feedback = false; highlight = NoHighlight }; - mode = Documentation; - }; scratch = ( 0, [ @@ -98,10 +67,11 @@ let startup : PersistentData.t = Convex))))))(ancestors())))(caret Outer))"; backup_text = ""; }; - ], - [ ("scratch_0", Evaluation); ("scratch_1", Evaluation) ] ); + ] + (* , + [ ("scratch_0", Evaluation); ("scratch_1", Evaluation) ] *) ); documentation = - ( "Basic Reference", + ( 2, [ ( "Casting", { @@ -17645,24 +17615,25 @@ let startup : PersistentData.t = Convex))))))(ancestors())))(caret Outer))"; backup_text = " "; } ); - ], - [ - ("scratch_ADT Dynamics", Evaluation); - ("scratch_ADT Statics", Evaluation); - ("scratch_Basic Reference", Evaluation); - ("scratch_Booleans and Types", Evaluation); - ("scratch_Casting", Evaluation); - ("scratch_Composing Arithmetic Expressions", Evaluation); - ("scratch_Compositionality", Evaluation); - ("scratch_Computing Equationally", Evaluation); - ("scratch_Conditional Expressions", Evaluation); - ("scratch_Functions", Evaluation); - ("scratch_Polymorphism", Evaluation); - ("scratch_Programming Expressively", Evaluation); - ("scratch_Projectors", Evaluation); - ("scratch_Scope", Evaluation); - ("scratch_Shadowing", Evaluation); - ("scratch_Types & static errors", Evaluation); - ("scratch_Variables", Evaluation); - ] ); + ] + (* , + [ + ("scratch_ADT Dynamics", Evaluation); + ("scratch_ADT Statics", Evaluation); + ("scratch_Basic Reference", Evaluation); + ("scratch_Booleans and Types", Evaluation); + ("scratch_Casting", Evaluation); + ("scratch_Composing Arithmetic Expressions", Evaluation); + ("scratch_Compositionality", Evaluation); + ("scratch_Computing Equationally", Evaluation); + ("scratch_Conditional Expressions", Evaluation); + ("scratch_Functions", Evaluation); + ("scratch_Polymorphism", Evaluation); + ("scratch_Programming Expressively", Evaluation); + ("scratch_Projectors", Evaluation); + ("scratch_Scope", Evaluation); + ("scratch_Shadowing", Evaluation); + ("scratch_Types & static errors", Evaluation); + ("scratch_Variables", Evaluation); + ] *) ); } diff --git a/src/haz3lweb/Keyboard.re b/src/haz3lweb/Keyboard.re index 7e4e655f26..2d39ac24a0 100644 --- a/src/haz3lweb/Keyboard.re +++ b/src/haz3lweb/Keyboard.re @@ -4,14 +4,6 @@ open Util; let is_digit = s => StringUtil.(match(regexp("^[0-9]$"), s)); let is_f_key = s => StringUtil.(match(regexp("^F[0-9][0-9]*$"), s)); -type shortcut = { - update_action: option(UpdateAction.t), - hotkey: option(string), - label: string, - mdIcon: option(string), - section: option(string), -}; - let meta = (sys: Key.sys): string => { switch (sys) { | Mac => "cmd" @@ -19,217 +11,8 @@ let meta = (sys: Key.sys): string => { }; }; -let mk_shortcut = - (~hotkey=?, ~mdIcon=?, ~section=?, label, update_action): shortcut => { - {update_action: Some(update_action), hotkey, label, mdIcon, section}; -}; - -let instructor_shortcuts: list(shortcut) = [ - mk_shortcut( - ~mdIcon="download", - ~section="Export", - "Export All Persistent Data", - Export(ExportPersistentData), - ), - mk_shortcut( - ~mdIcon="download", - ~section="Export", - "Export Exercise Module", - Export(ExerciseModule) // TODO Would we rather skip contextual stuff for now or include it and have it fail - ), - mk_shortcut( - ~mdIcon="download", - ~section="Export", - "Export Transitionary Exercise Module", - Export(TransitionaryExerciseModule) // TODO Would we rather skip contextual stuff for now or include it and have it fail - ), - mk_shortcut( - ~mdIcon="download", - ~section="Export", - "Export Grading Exercise Module", - Export(GradingExerciseModule) // TODO Would we rather skip contextual stuff for now or include it and have it fail - ), -]; - -// List of shortcuts configured to show up in the command palette and have hotkey support -let shortcuts = (sys: Key.sys): list(shortcut) => - [ - mk_shortcut(~mdIcon="undo", ~hotkey=meta(sys) ++ "+z", "Undo", Undo), - mk_shortcut( - ~hotkey=meta(sys) ++ "+shift+z", - ~mdIcon="redo", - "Redo", - Redo, - ), - mk_shortcut( - ~hotkey="F12", - ~mdIcon="arrow_forward", - ~section="Navigation", - "Go to Definition", - PerformAction(Jump(BindingSiteOfIndicatedVar)), - ), - mk_shortcut( - ~hotkey="shift+tab", - ~mdIcon="swipe_left_alt", - ~section="Navigation", - "Go to Previous Hole", - PerformAction(Move(Goal(Piece(Grout, Left)))), - ), - mk_shortcut( - ~mdIcon="swipe_right_alt", - ~section="Navigation", - "Go To Next Hole", - PerformAction(Move(Goal(Piece(Grout, Right)))), - // Tab is overloaded so not setting it here - ), - mk_shortcut( - ~hotkey=meta(sys) ++ "+d", - ~mdIcon="select_all", - ~section="Selection", - "Select current term", - PerformAction(Select(Term(Current))), - ), - mk_shortcut( - ~hotkey=meta(sys) ++ "+p", - ~mdIcon="backpack", - "Pick up selected term", - PerformAction(Pick_up), - ), - mk_shortcut( - ~mdIcon="select_all", - ~hotkey=meta(sys) ++ "+a", - ~section="Selection", - "Select All", - PerformAction(Select(All)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Statics", - UpdateAction.Set(Statics), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Completion", - UpdateAction.Set(Assist), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Whitespace", - UpdateAction.Set(SecondaryIcons), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Print Benchmarks", - UpdateAction.Set(Benchmark), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Toggle Dynamics", - UpdateAction.Set(Dynamics), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Elaboration", - UpdateAction.Set(Elaborate), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Function Bodies", - UpdateAction.Set(Evaluation(ShowFnBodies)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Case Clauses", - UpdateAction.Set(Evaluation(ShowCaseClauses)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show fixpoints", - UpdateAction.Set(Evaluation(ShowFixpoints)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Casts", - UpdateAction.Set(Evaluation(ShowCasts)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Lookup Steps", - UpdateAction.Set(Evaluation(ShowLookups)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Stepper Filters", - UpdateAction.Set(Evaluation(ShowFilters)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Hidden Steps", - UpdateAction.Set(Evaluation(ShowHiddenSteps)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Docs Sidebar", - UpdateAction.Set(ExplainThis(ToggleShow)), - ), - mk_shortcut( - ~section="Settings", - ~mdIcon="tune", - "Toggle Show Docs Feedback", - UpdateAction.Set(ExplainThis(ToggleShowFeedback)), - ), - mk_shortcut( - ~hotkey=meta(sys) ++ "+/", - ~mdIcon="assistant", - "TyDi Assistant", - PerformAction(Buffer(Set(TyDi))) // I haven't figured out how to trigger this in the editor - ), - mk_shortcut( - ~mdIcon="download", - ~section="Export", - "Export Scratch Slide", - Export(ExportScratchSlide), - ), - mk_shortcut( - ~mdIcon="download", - ~section="Export", - "Export Submission", - Export(Submission) // TODO Would we rather skip contextual stuff for now or include it and have it fail - ), - mk_shortcut( - // ctrl+k conflicts with the command palette - ~section="Diagnostics", - ~mdIcon="refresh", - "Reparse Current Editor", - PerformAction(Reparse), - ), - mk_shortcut( - ~mdIcon="timer", - ~section="Diagnostics", - ~hotkey="F7", - "Run Benchmark", - Benchmark(Start), - ), - ] - @ (if (ExerciseSettings.show_instructor) {instructor_shortcuts} else {[]}); - -let handle_key_event = (k: Key.t): option(UpdateAction.t) => { - let now = (a: Action.t): option(UpdateAction.t) => - Some(PerformAction(a)); +let handle_key_event = (k: Key.t): option(Action.t) => { + let now = (a: Action.t) => Some(a); switch (k) { | {key: U(key), _} => /* Keu-UPpEvents: @@ -237,14 +20,8 @@ let handle_key_event = (k: Key.t): option(UpdateAction.t) => { keydown, making an update here may trigger an entire extra redraw, contingent on model.cutoff */ switch (key) { - | "Alt" => Some(SetMeta(ShowBackpackTargets(false))) | _ => None } - | {key: D(key), sys: _, shift: Down, meta: Up, ctrl: Up, alt: Up} - when is_f_key(key) => - switch (key) { - | _ => Some(DebugConsole(key)) - } | {key: D(key), sys: _, shift, meta: Up, ctrl: Up, alt: Up} => switch (shift, key) { | (Up, "ArrowLeft") => now(Move(Local(Left(ByChar)))) @@ -256,7 +33,6 @@ let handle_key_event = (k: Key.t): option(UpdateAction.t) => { | (Up, "Backspace") => now(Destruct(Left)) | (Up, "Delete") => now(Destruct(Right)) | (Up, "Escape") => now(Unselect(None)) - | (Up, "Tab") => Some(TAB) | (Up, "F12") => now(Jump(BindingSiteOfIndicatedVar)) | (Down, "Tab") => now(Move(Goal(Piece(Grout, Left)))) | (Down, "ArrowLeft") => now(Select(Resize(Local(Left(ByToken))))) @@ -292,11 +68,11 @@ let handle_key_event = (k: Key.t): option(UpdateAction.t) => { } | {key: D(key), sys: Mac, shift: Up, meta: Down, ctrl: Up, alt: Up} => switch (key) { - | "z" => Some(Undo) | "d" => now(Select(Term(Current))) - | "p" => Some(PerformAction(Pick_up)) + | "p" => now(Pick_up) | "a" => now(Select(All)) - | "/" => Some(PerformAction(Buffer(Set(TyDi)))) + | "k" => Some(Reparse) + | "/" => Some(Buffer(Set(TyDi))) | "ArrowLeft" => now(Move(Extreme(Left(ByToken)))) | "ArrowRight" => now(Move(Extreme(Right(ByToken)))) | "ArrowUp" => now(Move(Extreme(Up))) @@ -305,11 +81,11 @@ let handle_key_event = (k: Key.t): option(UpdateAction.t) => { } | {key: D(key), sys: PC, shift: Up, meta: Up, ctrl: Down, alt: Up} => switch (key) { - | "z" => Some(Undo) | "d" => now(Select(Term(Current))) - | "p" => Some(PerformAction(Pick_up)) + | "p" => now(Pick_up) | "a" => now(Select(All)) - | "/" => Some(PerformAction(Buffer(Set(TyDi)))) + | "k" => Some(Reparse) + | "/" => Some(Buffer(Set(TyDi))) | "ArrowLeft" => now(Move(Local(Left(ByToken)))) | "ArrowRight" => now(Move(Local(Right(ByToken)))) | "Home" => now(Move(Extreme(Up))) @@ -323,15 +99,14 @@ let handle_key_event = (k: Key.t): option(UpdateAction.t) => { | _ => None } | {key: D("f"), sys: PC, shift: Up, meta: Up, ctrl: Up, alt: Down} => - Some(PerformAction(Project(ToggleIndicated(Fold)))) + Some(Project(ToggleIndicated(Fold))) | {key: D("ƒ"), sys: Mac, shift: Up, meta: Up, ctrl: Up, alt: Down} => /* Curly ƒ is what holding option turns f into on Mac */ - Some(PerformAction(Project(ToggleIndicated(Fold)))) + Some(Project(ToggleIndicated(Fold))) | {key: D(key), sys: _, shift: Up, meta: Up, ctrl: Up, alt: Down} => switch (key) { | "ArrowLeft" => now(MoveToBackpackTarget(Left(ByToken))) | "ArrowRight" => now(MoveToBackpackTarget(Right(ByToken))) - | "Alt" => Some(SetMeta(ShowBackpackTargets(true))) | "ArrowUp" => now(MoveToBackpackTarget(Up)) | "ArrowDown" => now(MoveToBackpackTarget(Down)) | _ => None diff --git a/src/haz3lweb/Main.re b/src/haz3lweb/Main.re index 16811a32cb..747cff3098 100644 --- a/src/haz3lweb/Main.re +++ b/src/haz3lweb/Main.re @@ -17,9 +17,51 @@ let restart_caret_animation = () => | _ => () }; -let apply = (model, action, ~schedule_action, ~schedule_autosave): Model.t => { +let apply = + ( + model: Page.Model.t, + action: Page.Update.t, + ~schedule_action, + ~schedule_autosave, + ) + : Page.Model.t => { restart_caret_animation(); - if (UpdateAction.is_edit(action)) { + + /* This function is split into two phases, update and calculate. + The intention is that eventually, the calculate phase will be + done automatically by incremental calculation. */ + // ---------- UPDATE PHASE ---------- + let updated: Updated.t(Page.Model.t) = + try( + Page.Update.update( + ~import_log=Log.import, + ~get_log_and=Log.get_and, + ~schedule_action, + action, + model, + ) + ) { + | Haz3lcore.Action.Failure.Exception(t) => + Printf.printf( + "ERROR: Action.Failure: %s\n", + t |> Haz3lcore.Action.Failure.show, + ); + model |> Updated.return_quiet; + | exc => + Printf.printf( + "ERROR: Exception during apply: %s\n", + Printexc.to_string(exc), + ); + model |> Updated.return_quiet; + }; + // ---------- CALCULATE PHASE ---------- + let model' = + updated.recalculate + ? updated.model + |> Page.Update.calculate(~schedule_action, ~is_edited=updated.is_edit) + : updated.model; + + if (updated.is_edit) { schedule_autosave( BonsaiUtil.Alarm.Action.SetAlarm( Core.Time_ns.add(Core.Time_ns.now(), Core.Time_ns.Span.of_sec(1.0)), @@ -32,55 +74,18 @@ let apply = (model, action, ~schedule_action, ~schedule_autosave): Model.t => { ), ); }; - if (Update.should_scroll_to_caret(action)) { + if (updated.scroll_active) { scroll_to_caret := true; }; - switch ( - try({ - let new_model = Update.apply(model, action, ~schedule_action); - Log.update(action); - new_model; - }) { - | exc => - Printf.printf( - "ERROR: Exception during apply: %s\n", - Printexc.to_string(exc), - ); - Error(Exception(Printexc.to_string(exc))); - } - ) { - | Ok(model) => model - | Error(FailedToPerform(err)) => - print_endline(Update.Failure.show(FailedToPerform(err))); - model; - | Error(err) => - print_endline(Update.Failure.show(err)); - model; - }; + model'; }; -/* This subcomponent is used to run an effect once when the app starts up, - After the first draw */ -let on_startup = effect => { - 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) - }; - }; - Bonsai.Edge.after_display(after_display); -}; - -let view = { +let start = { let%sub save_scheduler = BonsaiUtil.Alarm.alarm; - let%sub app = + let%sub (app_model, app_inject) = Bonsai.state_machine1( - (module Model), - (module Update), + (module Page.Model), + (module Page.Update), ~apply_action= (~inject, ~schedule_event, input) => { let schedule_action = x => schedule_event(inject(x)); @@ -92,14 +97,68 @@ let view = { }; apply(~schedule_action, ~schedule_autosave); }, - ~default_model=Model.load(Model.blank), + ~default_model=Page.Store.load(), save_scheduler, ); - let%sub () = { - on_startup( - Bonsai.Value.map(~f=((_model, inject)) => inject(Startup), app), + + // 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); + + // 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; }; + 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), + ]); + }, + ); + + // Triggers after every update let after_display = { Bonsai.Effect.of_sync_fun( () => @@ -110,15 +169,20 @@ let view = { (), ); }; - let save_effect = Bonsai.Value.map(~f=((_, g)) => g(Update.Save), app); - let%sub () = BonsaiUtil.Alarm.listen(save_scheduler, ~event=save_effect); let%sub () = Bonsai.Edge.after_display(after_display |> Bonsai.Value.return); - let%arr (model, inject) = app; - Haz3lweb.Page.view(~inject, model); + + // 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() -| _ => Bonsai_web.Start.start(view, ~bind_to_element_with_id="container") +| _ => Bonsai_web.Start.start(start, ~bind_to_element_with_id="container") }; diff --git a/src/haz3lweb/Model.re b/src/haz3lweb/Model.re deleted file mode 100644 index e4939b3af0..0000000000 --- a/src/haz3lweb/Model.re +++ /dev/null @@ -1,129 +0,0 @@ -open Util; - -open Haz3lcore; - -/* MODEL: - - The model consists of three broad categories. Editors is the meat, - containing the code content and cursor/selection/buffer state for all - active editors. Settings are user-selectable preferences. Together, - these two comprise the persistent state of the application which is - saved to localstore. - - Meta on the other hand consists of everything which is not - peristant, including transitory ui_state such as whether the mouse - is held down. - - */ - -[@deriving (show({with_path: false}), yojson, sexp)] -type timestamp = float; - -/* Non-persistent application state */ -[@deriving (show({with_path: false}), yojson, sexp)] -type ui_state = { - font_metrics: FontMetrics.t, - show_backpack_targets: bool, - mousedown: bool, -}; - -let ui_state_init = { - font_metrics: FontMetrics.init, - show_backpack_targets: false, - mousedown: false, -}; - -[@deriving sexp] -type t = { - editors: Editors.t, - settings: Settings.t, - results: ModelResults.t, - explainThisModel: ExplainThisModel.t, - ui_state, -}; - -let equal = (===); - -let mk = (editors, results) => { - editors, - settings: Init.startup.settings, - results, - explainThisModel: ExplainThisModel.init, - ui_state: ui_state_init, -}; - -let blank = mk(Editors.Scratch(0, []), ModelResults.empty); - -let load_editors = - (~settings, ~mode: Settings.mode, ~instructor_mode: bool) - : (Editors.t, ModelResults.t) => - switch (mode) { - | Scratch => - let (idx, slides, results) = Store.Scratch.load(~settings); - (Scratch(idx, slides), results); - | Documentation => - let (name, slides, results) = Store.Documentation.load(~settings); - (Documentation(name, slides), results); - | Exercises => - let (n, specs, exercise) = - Store.Exercise.load( - ~settings, - ~specs=ExerciseSettings.exercises, - ~instructor_mode, - ); - (Exercises(n, specs, exercise), ModelResults.empty); - }; - -let save_editors = - (editors: Editors.t, results: ModelResults.t, ~instructor_mode: bool) - : unit => - switch (editors) { - | Scratch(n, slides) => Store.Scratch.save((n, slides, results)) - | Documentation(name, slides) => - Store.Documentation.save((name, slides, results)) - | Exercises(n, specs, exercise) => - Store.Exercise.save((n, specs, exercise), ~instructor_mode) - }; - -let load = (init_model: t): t => { - let settings = Store.Settings.load(); - let explainThisModel = Store.ExplainThisModel.load(); - let (editors, results) = - load_editors( - ~settings=settings.core, - ~mode=settings.mode, - ~instructor_mode=settings.instructor_mode, - ); - let ui_state = init_model.ui_state; - {editors, settings, results, explainThisModel, ui_state}; -}; - -let save = ({editors, settings, explainThisModel, results, _}: t) => { - save_editors(editors, results, ~instructor_mode=settings.instructor_mode); - Store.ExplainThisModel.save(explainThisModel); - Store.Settings.save(settings); -}; - -let save_and_return = (model: t) => { - save(model); - Ok(model); -}; - -let reset = (model: t): t => { - /* Reset model to default, including in localstorage, - but don't otherwise erase localstorage, allowing - e.g. api keys to persist */ - let settings = Store.Settings.init().core; - ignore(Store.ExplainThisModel.init()); - ignore(Store.Scratch.init(~settings)); - ignore(Store.Documentation.init(~settings)); - ignore(Store.Exercise.init(~settings, ~instructor_mode=true)); - let new_model = load(blank); - { - ...new_model, - ui_state: { - ...model.ui_state, - font_metrics: model.ui_state.font_metrics, - }, - }; -}; diff --git a/src/haz3lweb/NinjaKeys.re b/src/haz3lweb/NinjaKeys.re index acce5c4ff4..f986ac9252 100644 --- a/src/haz3lweb/NinjaKeys.re +++ b/src/haz3lweb/NinjaKeys.re @@ -5,45 +5,6 @@ open Util; Configuration of the command palette using the https://github.com/ssleptsov/ninja-keys web component. */ -let from_shortcut = - (schedule_action: UpdateAction.t => unit, shortcut: Keyboard.shortcut) - : { - . - "handler": Js.readonly_prop(unit => unit), - "id": Js.readonly_prop(string), - "mdIcon": Js.readonly_prop(Js.optdef(string)), - "hotkey": Js.readonly_prop(Js.optdef(string)), - "title": Js.readonly_prop(string), - "section": Js.readonly_prop(Js.optdef(string)), - } => { - [%js - { - val id = shortcut.label; - val title = shortcut.label; - val mdIcon = Js.Optdef.option(shortcut.mdIcon); - val hotkey = Js.Optdef.option(shortcut.hotkey); - val section = Js.Optdef.option(shortcut.section); - val handler = - () => { - let foo = shortcut.update_action; - switch (foo) { - | Some(update) => schedule_action(update) - | None => - print_endline("Could not find action for " ++ shortcut.label) - }; - } - }]; -}; - -let options = (schedule_action: UpdateAction.t => unit) => { - Array.of_list( - List.map( - from_shortcut(schedule_action), - Keyboard.shortcuts(Os.is_mac^ ? Mac : PC), - ), - ); -}; - let elem = () => JsUtil.get_elem_by_id("ninja-keys"); let initialize = opts => Js.Unsafe.set(elem(), "data", Js.array(opts)); diff --git a/src/haz3lweb/PersistentData.re b/src/haz3lweb/PersistentData.re index 8b606f4d17..118114cef8 100644 --- a/src/haz3lweb/PersistentData.re +++ b/src/haz3lweb/PersistentData.re @@ -1,24 +1,7 @@ open Util; -open Haz3lcore; - -[@deriving (show({with_path: false}), sexp, yojson)] -type scratch = ( - int, - list(ScratchSlide.persistent_state), - list((string, ModelResult.persistent)), -); - -[@deriving (show({with_path: false}), sexp, yojson)] -type documentation = ( - string, - list((string, ScratchSlide.persistent_state)), - [@default []] list((string, ModelResult.persistent)), -); - [@deriving (show({with_path: false}), sexp, yojson)] type t = { - settings: Settings.t, - scratch, - documentation, + scratch: (int, list(CellEditor.Model.persistent)), + documentation: (int, list((string, CellEditor.Model.persistent))), }; diff --git a/src/haz3lweb/ScratchSlide.re b/src/haz3lweb/ScratchSlide.re deleted file mode 100644 index 554beab53d..0000000000 --- a/src/haz3lweb/ScratchSlide.re +++ /dev/null @@ -1,52 +0,0 @@ -open Haz3lcore; - -[@deriving (show({with_path: false}), sexp, yojson)] -type state = Editor.t; - -[@deriving (show({with_path: false}), sexp, yojson)] -type persistent_state = PersistentZipper.t; - -let scratch_key = n => "scratch_" ++ n; - -let persist = (editor: Editor.t): persistent_state => { - PersistentZipper.persist(editor.state.zipper); -}; - -let unpersist = (zipper: persistent_state, ~settings: CoreSettings.t): state => { - let zipper = PersistentZipper.unpersist(zipper); - Editor.init(zipper, ~read_only=false, ~settings); -}; - -let serialize = (state: state): string => { - persist(state) |> sexp_of_persistent_state |> Sexplib.Sexp.to_string; -}; - -let deserialize = (data: string, ~settings: CoreSettings.t): state => { - Sexplib.Sexp.of_string(data) - |> persistent_state_of_sexp - |> unpersist(~settings); -}; - -let deserialize_opt = - (data: string, ~settings: CoreSettings.t): option(state) => { - let sexp = - try(Some(Sexplib.Sexp.of_string(data) |> persistent_state_of_sexp)) { - | _ => None - }; - sexp |> Option.map(sexp => sexp |> unpersist(~settings)); -}; - -let export = (state: state): Yojson.Safe.t => { - state |> persist |> yojson_of_persistent_state; -}; - -let import = (data: string, ~settings: CoreSettings.t): state => { - data - |> Yojson.Safe.from_string - |> persistent_state_of_yojson - |> unpersist(~settings); -}; - -let export_init = (state: state): string => { - state |> persist |> show_persistent_state; -}; diff --git a/src/haz3lweb/ScratchSlidesInit.re b/src/haz3lweb/ScratchSlidesInit.re deleted file mode 100644 index 00720b0bd9..0000000000 --- a/src/haz3lweb/ScratchSlidesInit.re +++ /dev/null @@ -1,19 +0,0 @@ -let filled_slides = []; - -let empty: ScratchSlide.persistent_state = { - zipper: "((selection((focus Left)(content())))(backpack())(relatives((siblings(()((Grout((id 0)(shape Convex))))))(ancestors())))(caret Outer))", - backup_text: "", -}; - -let num_empty = 8; - -let init_data = filled_slides @ List.init(num_empty, _ => empty); - -assert(List.length(init_data) > 0); - -let init = () => (0, init_data |> List.map(ScratchSlide.unpersist)); - -let init_nth = n => { - let data = List.nth(init_data, n); - ScratchSlide.unpersist(data); -}; diff --git a/src/haz3lweb/Settings.re b/src/haz3lweb/Settings.re index 1481b54621..d9d369dfe3 100644 --- a/src/haz3lweb/Settings.re +++ b/src/haz3lweb/Settings.re @@ -1,35 +1,224 @@ open Util; -[@deriving (show({with_path: false}), sexp, yojson)] -type mode = - | Scratch - | Documentation - | Exercises; - -let mode_of_string = (s: string): mode => - switch (s) { - | "Scratch" => Scratch - | "Documentation" => Documentation - | "Exercises" => Exercises - | _ => failwith("mode_of_string: unknown mode:" ++ s) +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + captions: bool, + secondary_icons: bool, + core: Haz3lcore.CoreSettings.t, + async_evaluation: bool, + context_inspector: bool, + instructor_mode: bool, + benchmark: bool, + explainThis: ExplainThisModel.Settings.t, }; -[@deriving (show({with_path: false}), sexp, yojson)] -type t = { - captions: bool, - secondary_icons: bool, - core: Haz3lcore.CoreSettings.t, - async_evaluation: bool, - context_inspector: bool, - instructor_mode: bool, - benchmark: bool, - explainThis: ExplainThisModel.Settings.t, - mode, + let init = { + captions: true, + secondary_icons: false, + core: { + statics: true, + elaborate: false, + assist: true, + dynamics: true, + evaluation: { + show_case_clauses: true, + show_fn_bodies: false, + show_fixpoints: false, + show_casts: false, + show_lookup_steps: false, + show_stepper_filters: false, + stepper_history: false, + show_settings: false, + show_hidden_steps: false, + }, + }, + async_evaluation: false, + context_inspector: false, + instructor_mode: true, + benchmark: false, + explainThis: { + show: true, + show_feedback: false, + highlight: NoHighlight, + }, + }; + + let fix_instructor_mode = settings => + if (settings.instructor_mode && !ExerciseSettings.show_instructor) { + {...settings, instructor_mode: false}; + } else { + settings; + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = t; + + let persist = x => x; + let unpersist = fix_instructor_mode; }; -let fix_instructor_mode = settings => - if (settings.instructor_mode && !ExerciseSettings.show_instructor) { - {...settings, instructor_mode: false}; - } else { - settings; +module Store = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = Model.persistent; + let key = Store.Settings; + let default = () => Model.init; + }); + +module Update = { + [@deriving (show({with_path: false}), sexp, yojson)] + type evaluation = + | ShowRecord + | ShowCaseClauses + | ShowFnBodies + | ShowCasts + | ShowFixpoints + | ShowLookups + | ShowFilters + | ShowSettings + | ShowHiddenSteps; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Captions + | SecondaryIcons + | Statics + | Dynamics + | Assist + | Elaborate + | Benchmark + | ContextInspector + | InstructorMode + | Evaluation(evaluation) + | ExplainThis(ExplainThisModel.Settings.action); + + let update = (action, settings: Model.t): Updated.t(Model.t) => { + ( + switch (action) { + | Statics => { + ...settings, + core: { + ...settings.core, + statics: !settings.core.statics, + assist: !settings.core.statics, + dynamics: !settings.core.statics && settings.core.dynamics, + }, + } + | Elaborate => { + ...settings, + core: { + ...settings.core, + statics: !settings.core.elaborate || settings.core.statics, + elaborate: !settings.core.elaborate, + }, + } + | Dynamics => { + ...settings, + core: { + ...settings.core, + statics: !settings.core.dynamics || settings.core.statics, + dynamics: !settings.core.dynamics, + }, + } + | Assist => { + ...settings, + core: { + ...settings.core, + statics: !settings.core.assist || settings.core.statics, + assist: !settings.core.assist, + }, + } + | Evaluation(u) => + let evaluation = settings.core.evaluation; + let evaluation: Haz3lcore.CoreSettings.Evaluation.t = + switch (u) { + | ShowRecord => { + ...evaluation, + stepper_history: !evaluation.stepper_history, + } + | ShowCaseClauses => { + ...evaluation, + show_case_clauses: !evaluation.show_case_clauses, + } + | ShowFnBodies => { + ...evaluation, + show_fn_bodies: !evaluation.show_fn_bodies, + } + | ShowCasts => {...evaluation, show_casts: !evaluation.show_casts} + | ShowFixpoints => { + ...evaluation, + show_fixpoints: !evaluation.show_fixpoints, + } + | ShowLookups => { + ...evaluation, + show_lookup_steps: !evaluation.show_lookup_steps, + } + | ShowFilters => { + ...evaluation, + show_stepper_filters: !evaluation.show_stepper_filters, + } + | ShowSettings => { + ...evaluation, + show_settings: !evaluation.show_settings, + } + | ShowHiddenSteps => { + ...evaluation, + show_hidden_steps: !evaluation.show_hidden_steps, + } + }; + { + ...settings, + core: { + ...settings.core, + evaluation, + }, + }; + | ExplainThis(ToggleShow) => { + ...settings, + explainThis: { + ...settings.explainThis, + show: !settings.explainThis.show, + }, + } + | ExplainThis(ToggleShowFeedback) => { + ...settings, + explainThis: { + ...settings.explainThis, + show_feedback: !settings.explainThis.show_feedback, + }, + } + | ExplainThis(SetHighlight(a)) => + let highlight: ExplainThisModel.Settings.highlight = + switch (a, settings.explainThis.highlight) { + | (Toggle, All) => NoHighlight + | (Toggle, _) => All + | (Hover(_), All) => All + | (Hover(id), _) => One(id) + | (UnsetHover, All) => All + | (UnsetHover, _) => NoHighlight + }; + let explainThis = {...settings.explainThis, highlight}; + {...settings, explainThis}; + | Benchmark => {...settings, benchmark: !settings.benchmark} + | Captions => {...settings, captions: !settings.captions} + | SecondaryIcons => { + ...settings, + secondary_icons: !settings.secondary_icons, + } + | ContextInspector => { + ...settings, + context_inspector: !settings.context_inspector, + } + | InstructorMode => { + ...settings, //TODO[Matt]: Make sure instructor mode actually makes prelude read-only + instructor_mode: !settings.instructor_mode, + } + } + ) + |> Updated.return(~scroll_active=false); }; +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type t = Model.t; diff --git a/src/haz3lweb/State.re b/src/haz3lweb/State.re deleted file mode 100644 index 9750db6a57..0000000000 --- a/src/haz3lweb/State.re +++ /dev/null @@ -1,2 +0,0 @@ -type t = unit; -let init = () => (); diff --git a/src/haz3lweb/Store.re b/src/haz3lweb/Store.re index f30a18ab85..0665dcbce7 100644 --- a/src/haz3lweb/Store.re +++ b/src/haz3lweb/Store.re @@ -1,100 +1,63 @@ -open Haz3lcore; open Util; - // A generic key-value store for saving/loading data to/from local storage -module Generic = { - let prefix: string = "KEY_STORE_"; - - let full_key = (key: string): string => { - prefix ++ key; - }; - - let save = (key: string, value: string): unit => - JsUtil.set_localstore(full_key(key), value); - - let load = (key: string): option(string) => - JsUtil.get_localstore(full_key(key)); -}; - -// Settings serialization -module Settings = { - let save_settings_key: string = "SETTINGS"; - let default = Init.startup.settings; - - let serialize = settings => - settings |> Settings.sexp_of_t |> Sexplib.Sexp.to_string; - - let deserialize = data => - try( - data - |> Sexplib.Sexp.of_string - |> Settings.t_of_sexp - |> Settings.fix_instructor_mode - ) { +type key = + | Settings + | ExplainThis + | Mode + | Scratch + | Documentation + | CurrentExercise + | Exercise(Exercise.key); + +let key_to_string = + fun + | Settings => "SETTINGS" + | ExplainThis => "ExplainThisModel" + | Mode => "MODE" + | Scratch => "SAVE_SCRATCH" + | Documentation => "SAVE_DOCUMENTATION" + | CurrentExercise => "CUR_EXERCISE" + | Exercise(key) => key |> Exercise.sexp_of_key |> Sexplib.Sexp.to_string; + +module F = + ( + STORE_KIND: { + [@deriving (show({with_path: false}), sexp, yojson)] + type t; + let default: unit => t; + let key: key; + }, + ) => { + include STORE_KIND; + + let serialize = (data: t) => { + data |> sexp_of_t |> Sexplib.Sexp.to_string; + }; + + let deserialize = (data: string, default: t) => + try(data |> Sexplib.Sexp.of_string |> t_of_sexp) { | _ => - print_endline("Could not deserialize settings."); + print_endline("Could not deserialize " ++ key_to_string(key) ++ "."); default; }; - let save = (settings: Settings.t): unit => - JsUtil.set_localstore(save_settings_key, serialize(settings)); - - let init = () => { - JsUtil.set_localstore(save_settings_key, serialize(default)); - default; - }; - - let load = (): Settings.t => - switch (JsUtil.get_localstore(save_settings_key)) { - | None => init() - | Some(data) => deserialize(data) - }; - - let export = () => Option.get(JsUtil.get_localstore(save_settings_key)); - let import = data => { - let settings = deserialize(data); - save(settings); - settings; - }; -}; - -// ExplainThisModel serialization -module ExplainThisModel = { - let save_ExplainThisModel_key: string = "ExplainThisModel"; - - let serialize = explainThisModel => - explainThisModel |> ExplainThisModel.sexp_of_t |> Sexplib.Sexp.to_string; - - let deserialize = data => - try(data |> Sexplib.Sexp.of_string |> ExplainThisModel.t_of_sexp) { - | _ => - print_endline("Could not deserialize ExplainThisModel."); - ExplainThisModel.init; - }; - - let save = (explainThisModel: ExplainThisModel.t): unit => - JsUtil.set_localstore( - save_ExplainThisModel_key, - serialize(explainThisModel), - ); + let save = (data: t): unit => + JsUtil.set_localstore(key_to_string(key), serialize(data)); let init = () => { - JsUtil.set_localstore( - save_ExplainThisModel_key, - serialize(ExplainThisModel.init), - ); - ExplainThisModel.init; + JsUtil.set_localstore(key_to_string(key), serialize(default())); + default(); }; - let load = (): ExplainThisModel.t => - switch (JsUtil.get_localstore(save_ExplainThisModel_key)) { + let load = (): t => + switch (JsUtil.get_localstore(key_to_string(key))) { | None => init() - | Some(data) => deserialize(data) + | Some(data) => deserialize(data, default()) }; let rec export = () => - switch (JsUtil.get_localstore(save_ExplainThisModel_key)) { + switch (JsUtil.get_localstore(key_to_string(key))) { | None => let _ = init(); export(); @@ -102,331 +65,7 @@ module ExplainThisModel = { }; let import = data => { - let explainThisModel = deserialize(data); - save(explainThisModel); - }; -}; - -// Scratch mode serialization -module Scratch = { - let save_scratch_key: string = "SAVE_SCRATCH"; - - [@deriving (show({with_path: false}), sexp, yojson)] - type persistent = PersistentData.scratch; - - [@deriving (show({with_path: false}), sexp, yojson)] - type t = (int, list(Editor.t), ModelResults.M.t(ModelResult.t)); - - let to_persistent = ((idx, slides, results)): persistent => ( - idx, - List.map(ScratchSlide.persist, slides), - results - |> ModelResults.map(ModelResult.to_persistent) - |> ModelResults.bindings, - ); - - let of_persistent = - (~settings: CoreSettings.t, (idx, slides, results): persistent): t => { - ( - idx, - List.map(ScratchSlide.unpersist(~settings), slides), - results - |> List.to_seq - |> ModelResults.of_seq - |> ModelResults.map( - ModelResult.of_persistent(~settings=settings.evaluation), - ), - ); - }; - - let serialize = (scratch: t): string => { - scratch |> to_persistent |> sexp_of_persistent |> Sexplib.Sexp.to_string; - }; - - let deserialize = (data: string, ~settings: CoreSettings.t): t => { - data - |> Sexplib.Sexp.of_string - |> persistent_of_sexp - |> of_persistent(~settings); - }; - - let save = (scratch: t): unit => { - JsUtil.set_localstore(save_scratch_key, serialize(scratch)); - }; - - let init = (~settings: CoreSettings.t): t => { - let scratch = of_persistent(~settings, Init.startup.scratch); - save(scratch); - scratch; - }; - - let load = (~settings: CoreSettings.t): t => - switch (JsUtil.get_localstore(save_scratch_key)) { - | None => init(~settings) - | Some(data) => - try(deserialize(~settings, data)) { - | _ => init(~settings) - } - }; - - let export = (~settings: CoreSettings.t): string => - serialize(load(~settings)); - let import = (~settings: CoreSettings.t, data: string): unit => - save(deserialize(~settings, data)); -}; - -module Documentation = { - let save_documentation_key: string = "SAVE_DOCUMENTATION"; - - [@deriving (show({with_path: false}), sexp, yojson)] - type persistent = PersistentData.documentation; - - [@deriving (show({with_path: false}), sexp, yojson)] - type t = ( - string, - list((string, Editor.t)), - ModelResults.M.t(ModelResult.t), - ); - - let persist = ((name, editor: Editor.t)) => { - (name, PersistentZipper.persist(editor.state.zipper)); - }; - - let unpersist = ((name, zipper), ~settings: CoreSettings.t) => { - let zipper = PersistentZipper.unpersist(zipper); - (name, Editor.init(zipper, ~read_only=false, ~settings)); - }; - - let to_persistent = ((string, slides, results)): persistent => ( - string, - List.map(persist, slides), - results - |> ModelResults.map(ModelResult.to_persistent) - |> ModelResults.bindings, - ); - - let of_persistent = - (~settings: CoreSettings.t, (string, slides, results): persistent): t => { - ( - string, - List.map(unpersist(~settings), slides), - results - |> List.to_seq - |> ModelResults.of_seq - |> ModelResults.map( - ModelResult.of_persistent(~settings=settings.evaluation), - ), - ); - }; - - let serialize = (slides: t): string => { - slides |> to_persistent |> sexp_of_persistent |> Sexplib.Sexp.to_string; - }; - - let deserialize = (~settings: CoreSettings.t, data: string): t => { - data - |> Sexplib.Sexp.of_string - |> persistent_of_sexp - |> of_persistent(~settings); - }; - - let save = (slides: t): unit => { - JsUtil.set_localstore(save_documentation_key, serialize(slides)); - }; - - let init = (~settings: CoreSettings.t): t => { - let documentation = of_persistent(~settings, Init.startup.documentation); - save(documentation); - documentation; - }; - - let load = (~settings: CoreSettings.t): t => - switch (JsUtil.get_localstore(save_documentation_key)) { - | None => init(~settings) - | Some(data) => - try(deserialize(~settings, data)) { - | _ => init(~settings) - } - }; - - let export = (~settings: CoreSettings.t): string => - serialize(load(~settings)); - let import = (~settings: CoreSettings.t, data: string): unit => - save(deserialize(~settings, data)); -}; - -module Exercise = { - open Exercise; - - let cur_exercise_key = "CUR_EXERCISE"; - - let keystring_of_key = key => { - key |> sexp_of_key |> Sexplib.Sexp.to_string; - }; - - let keystring_of = p => { - key_of(p) |> keystring_of_key; - }; - - let key_of_keystring = keystring => { - keystring |> Sexplib.Sexp.of_string |> key_of_sexp; - }; - - let save_exercise_key = key => { - JsUtil.set_localstore(cur_exercise_key, keystring_of_key(key)); - }; - - let save_exercise = (exercise, ~instructor_mode): unit => { - let key = Exercise.key_of_state(exercise); - let keystring = keystring_of_key(key); - let value = Exercise.serialize_exercise(exercise, ~instructor_mode); - JsUtil.set_localstore(keystring, value); - }; - - let init_exercise = - (~settings: CoreSettings.t, spec, ~instructor_mode): state => { - let key = Exercise.key_of(spec); - let keystring = keystring_of_key(key); - let exercise = Exercise.state_of_spec(spec, ~instructor_mode, ~settings); - save_exercise(exercise, ~instructor_mode); - JsUtil.set_localstore(cur_exercise_key, keystring); - exercise; - }; - - let load_exercise = - (~settings: CoreSettings.t, key, spec, ~instructor_mode): Exercise.state => { - let keystring = keystring_of_key(key); - switch (JsUtil.get_localstore(keystring)) { - | Some(data) => - let exercise = - try( - Exercise.deserialize_exercise( - data, - ~spec, - ~instructor_mode, - ~settings, - ) - ) { - | _ => init_exercise(spec, ~instructor_mode, ~settings) - }; - JsUtil.set_localstore(cur_exercise_key, keystring); - exercise; - | None => init_exercise(spec, ~instructor_mode, ~settings) - }; - }; - - let save = ((n, specs, exercise), ~instructor_mode): unit => { - let key = key_of(List.nth(specs, n)); - let keystring = keystring_of_key(key); - save_exercise(exercise, ~instructor_mode); - JsUtil.set_localstore(cur_exercise_key, keystring); - }; - - let init = - (~settings: CoreSettings.t, ~instructor_mode) - : (int, list(spec), state) => { - let exercises = { - ( - 0, - ExerciseSettings.exercises, - List.nth(ExerciseSettings.exercises, 0) - |> Exercise.state_of_spec(~instructor_mode, ~settings), - ); - }; - save(exercises, ~instructor_mode); - exercises; - }; - - let load = - (~settings: CoreSettings.t, ~specs, ~instructor_mode) - : (int, list(p(ZipperBase.t)), state) => { - switch (JsUtil.get_localstore(cur_exercise_key)) { - | Some(keystring) => - let key = key_of_keystring(keystring); - switch (Exercise.find_key_opt(key, specs)) { - | Some((n, spec)) => - switch (JsUtil.get_localstore(keystring)) { - | Some(data) => - let exercise = - try( - deserialize_exercise(data, ~spec, ~instructor_mode, ~settings) - ) { - | _ => init_exercise(spec, ~instructor_mode, ~settings) - }; - (n, specs, exercise); - | None => - // initialize exercise from spec - let exercise = - Exercise.state_of_spec(spec, ~instructor_mode, ~settings); - save_exercise(exercise, ~instructor_mode); - (n, specs, exercise); - } - | None => - // invalid current exercise key saved, load the first exercise - let first_spec = List.nth(specs, 0); - let first_key = Exercise.key_of(first_spec); - ( - 0, - specs, - load_exercise(first_key, first_spec, ~instructor_mode, ~settings), - ); - }; - | None => init(~instructor_mode, ~settings) - }; - }; - - let prep_exercise_export = - (~specs, ~instructor_mode: bool, ~settings: CoreSettings.t) - : exercise_export => { - { - cur_exercise: - key_of_keystring( - Option.get(JsUtil.get_localstore(cur_exercise_key)), - ), - exercise_data: - specs - |> List.map(spec => { - let key = Exercise.key_of(spec); - let exercise = - load_exercise(key, spec, ~instructor_mode, ~settings) - |> Exercise.persistent_state_of_state(~instructor_mode); - (key, exercise); - }), - }; - }; - - let serialize_exercise_export = - (~specs, ~instructor_mode, ~settings: CoreSettings.t) => { - prep_exercise_export(~specs, ~instructor_mode, ~settings) - |> sexp_of_exercise_export - |> Sexplib.Sexp.to_string; - }; - - let export = (~specs, ~instructor_mode) => { - serialize_exercise_export(~specs, ~instructor_mode); - }; - - let import = - (data, ~specs, ~instructor_mode: bool, ~settings: CoreSettings.t) => { - let exercise_export = data |> deserialize_exercise_export; - save_exercise_key(exercise_export.cur_exercise); - exercise_export.exercise_data - |> List.iter(((key, persistent_state)) => { - let spec = Exercise.find_key_opt(key, specs); - switch (spec) { - | None => - print_endline("Warning: saved key does not correspond to exercise") - | Some((_, spec)) => - save_exercise( - Exercise.unpersist_state( - persistent_state, - ~spec, - ~instructor_mode, - ~settings, - ), - ~instructor_mode, - ) - }; - }); + let data = deserialize(data, default()); + save(data); }; }; diff --git a/src/haz3lweb/Update.re b/src/haz3lweb/Update.re deleted file mode 100644 index 778df5114a..0000000000 --- a/src/haz3lweb/Update.re +++ /dev/null @@ -1,581 +0,0 @@ -open Util; -open Js_of_ocaml; -open Haz3lcore; - -include UpdateAction; // to prevent circularity - -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( - FontMetrics.{ - row_height: rect##.bottom -. rect##.top, - col_width: rect##.right -. rect##.left, - }, - ); - }, - (), - ); - -let update_settings = - (a: settings_action, {settings, _} as model: Model.t): Model.t => - switch (a) { - | Statics => - /* NOTE: dynamics depends on statics, so if dynamics is on and - we're turning statics off, turn dynamics off as well */ - { - ...model, - settings: { - ...settings, - core: { - statics: !settings.core.statics, - assist: !settings.core.statics, - elaborate: settings.core.elaborate, - dynamics: !settings.core.statics && settings.core.dynamics, - evaluation: settings.core.evaluation, - }, - }, - } - | Elaborate => { - ...model, - settings: { - ...settings, - core: { - statics: !settings.core.elaborate || settings.core.statics, - assist: settings.core.assist, - elaborate: !settings.core.elaborate, - dynamics: settings.core.dynamics, - evaluation: settings.core.evaluation, - }, - }, - } - | Dynamics => { - ...model, - settings: { - ...settings, - core: { - statics: !settings.core.dynamics || settings.core.statics, - assist: settings.core.assist, - elaborate: settings.core.elaborate, - dynamics: !settings.core.dynamics, - evaluation: settings.core.evaluation, - }, - }, - } - | Assist => { - ...model, - settings: { - ...settings, - core: { - statics: !settings.core.assist || settings.core.statics, - assist: !settings.core.assist, - elaborate: settings.core.elaborate, - dynamics: settings.core.dynamics, - evaluation: settings.core.evaluation, - }, - }, - } - | Evaluation(u) => - let evaluation = settings.core.evaluation; - let evaluation' = { - switch (u) { - | ShowRecord => { - ...evaluation, - stepper_history: !evaluation.stepper_history, - } - | ShowCaseClauses => { - ...evaluation, - show_case_clauses: !evaluation.show_case_clauses, - } - | ShowFnBodies => { - ...evaluation, - show_fn_bodies: !evaluation.show_fn_bodies, - } - | ShowCasts => {...evaluation, show_casts: !evaluation.show_casts} - | ShowFixpoints => { - ...evaluation, - show_fixpoints: !evaluation.show_fixpoints, - } - | ShowLookups => { - ...evaluation, - show_lookup_steps: !evaluation.show_lookup_steps, - } - | ShowFilters => { - ...evaluation, - show_stepper_filters: !evaluation.show_stepper_filters, - } - | ShowSettings => { - ...evaluation, - show_settings: !evaluation.show_settings, - } - | ShowHiddenSteps => { - ...evaluation, - show_hidden_steps: !evaluation.show_hidden_steps, - } - }; - }; - { - ...model, - settings: { - ...settings, - core: { - ...settings.core, - evaluation: evaluation', - }, - }, - }; - | ExplainThis(ToggleShow) => - let explainThis = { - ...settings.explainThis, - show: !settings.explainThis.show, - }; - let settings = {...settings, explainThis}; - {...model, settings}; - | ExplainThis(ToggleShowFeedback) => - let explainThis = { - ...settings.explainThis, - show_feedback: !settings.explainThis.show_feedback, - }; - let settings = {...settings, explainThis}; - {...model, settings}; - | ExplainThis(SetHighlight(a)) => - let highlight: ExplainThisModel.Settings.highlight = - switch (a, settings.explainThis.highlight) { - | (Toggle, All) => NoHighlight - | (Toggle, _) => All - | (Hover(_), All) => All - | (Hover(id), _) => One(id) - | (UnsetHover, All) => All - | (UnsetHover, _) => NoHighlight - }; - let explainThis = {...settings.explainThis, highlight}; - let settings = {...settings, explainThis}; - {...model, settings}; - | Benchmark => { - ...model, - settings: { - ...settings, - benchmark: !settings.benchmark, - }, - } - | Captions => { - ...model, - settings: { - ...settings, - captions: !settings.captions, - }, - } - | SecondaryIcons => { - ...model, - settings: { - ...settings, - secondary_icons: !settings.secondary_icons, - }, - } - | ContextInspector => { - ...model, - settings: { - ...settings, - context_inspector: !settings.context_inspector, - }, - } - | InstructorMode => - let new_mode = !settings.instructor_mode; - { - ...model, - editors: Editors.set_instructor_mode(model.editors, new_mode), - settings: { - ...settings, - instructor_mode: !settings.instructor_mode, - }, - }; - | Mode(mode) => { - ...model, - settings: { - ...settings, - mode, - }, - } - }; - -let schedule_evaluation = (~schedule_action, model: Model.t): unit => - if (model.settings.core.dynamics) { - let elabs = - Editors.get_spliced_elabs(~settings=model.settings.core, model.editors); - let eval_rs = ModelResults.to_evaluate(model.results, elabs); - if (!ModelResults.is_empty(eval_rs)) { - schedule_action(UpdateResult(eval_rs)); - WorkerClient.request( - eval_rs, - ~handler=rs => schedule_action(UpdateResult(rs)), - ~timeout= - rqs => - schedule_action(UpdateResult(ModelResults.timeout_all(rqs))), - ); - }; - /* Not sending stepper to worker for now bc closure perf */ - let step_rs = ModelResults.to_step(model.results); - if (!ModelResults.is_empty(step_rs)) { - let new_rs = - step_rs - |> ModelResults.update_elabs( - ~settings=model.settings.core.evaluation, - elabs, - ) - |> ModelResults.run_pending(~settings=model.settings.core); - schedule_action(UpdateResult(new_rs)); - }; - }; - -let on_startup = - (~schedule_action: UpdateAction.t => unit, m: Model.t): Model.t => { - let _ = - observe_font_specimen("font-specimen", fm => - schedule_action(UpdateAction.SetMeta(FontMetrics(fm))) - ); - NinjaKeys.initialize(NinjaKeys.options(schedule_action)); - JsUtil.focus_clipboard_shim(); - /* initialize state. */ - /* Initial evaluation on a worker */ - schedule_evaluation(~schedule_action, m); - Os.is_mac := - Dom_html.window##.navigator##.platform##toUpperCase##indexOf( - Js.string("MAC"), - ) - >= 0; - m; -}; - -let update_cached_data = (~schedule_action, update, m: Model.t): Model.t => { - let update_dynamics = reevaluate_post_update(update); - /* If we switch editors, or change settings which require statics - * when statics was previously off, we may need updated statics */ - let non_edit_action_requiring_statics_refresh = - update_dynamics - && ( - switch (update) { - | PerformAction(_) => false - | _ => true - } - ); - let m = - if (non_edit_action_requiring_statics_refresh) { - { - ...m, - editors: - Editors.update_current_editor_statics(m.settings.core, m.editors), - }; - } else { - m; - }; - if (update_dynamics && m.settings.core.dynamics) { - schedule_evaluation(~schedule_action, m); - m; - } else { - m; - }; -}; - -let switch_scratch_slide = - (~settings, editors: Editors.t, ~instructor_mode, idx: int) - : option(Editors.t) => - switch (editors) { - | Documentation(_) => None - | Scratch(n, _) when n == idx => None - | Scratch(_, slides) when idx >= List.length(slides) => None - | Scratch(_, slides) => Some(Scratch(idx, slides)) - | Exercises(_, specs, _) when idx >= List.length(specs) => None - | Exercises(_, specs, _) => - let spec = List.nth(specs, idx); - let key = Exercise.key_of(spec); - let exercise = - Store.Exercise.load_exercise(key, spec, ~instructor_mode, ~settings); - Some(Exercises(idx, specs, exercise)); - }; - -let switch_exercise_editor = - (editors: Editors.t, ~pos, ~instructor_mode): option(Editors.t) => - switch (editors) { - | Documentation(_) - | Scratch(_) => None - | Exercises(m, specs, exercise) => - let exercise = Exercise.switch_editor(~pos, instructor_mode, ~exercise); - //Note: now saving after each edit (delayed by 1 second) so no need to save here - //Store.Exercise.save_exercise(exercise, ~instructor_mode); - Some(Exercises(m, specs, exercise)); - }; - -/* This action saves a file which serializes all current editor - settings, including the states of all Scratch and Example slides. - This saved file can directly replace Haz3lweb/Init.ml, allowing - you to make your current state the default startup state. - - This does NOT save any Exercises mode state or any langdocs - state. The latter is intentional as we don't want to persist - this between users. The former is a TODO, currently difficult - due to the more complex architecture of Exercises. */ -let export_persistent_data = () => { - // TODO Is this parsing and reserializing? - let settings = Store.Settings.load(); - let data: PersistentData.t = { - documentation: - Store.Documentation.load(~settings=settings.core) - |> Store.Documentation.to_persistent, - scratch: - Store.Scratch.load(~settings=settings.core) - |> Store.Scratch.to_persistent, - settings, - }; - let contents = - "let startup : PersistentData.t = " ++ PersistentData.show(data); - JsUtil.download_string_file( - ~filename="Init.ml", - ~content_type="text/plain", - ~contents, - ); - print_endline("INFO: Persistent data exported to Init.ml"); -}; -let export_scratch_slide = (editor: Editor.t): unit => { - let json_data = ScratchSlide.export(editor); - JsUtil.download_json("hazel-scratchpad", json_data); -}; - -let export_exercise_module = (exercise: Exercise.state): unit => { - let module_name = exercise.eds.module_name; - let filename = exercise.eds.module_name ++ ".ml"; - let content_type = "text/plain"; - let contents = Exercise.export_module(module_name, exercise); - JsUtil.download_string_file(~filename, ~content_type, ~contents); -}; - -let export_submission = (~instructor_mode) => - Log.get_and(log => { - let data = Export.export_all(~instructor_mode, ~log); - JsUtil.download_json(ExerciseSettings.filename, data); - }); - -let export_transitionary = (exercise: Exercise.state) => { - // .ml files because show uses OCaml syntax (dune handles seamlessly) - let module_name = exercise.eds.module_name; - let filename = exercise.eds.module_name ++ ".ml"; - let content_type = "text/plain"; - let contents = Exercise.export_transitionary_module(module_name, exercise); - JsUtil.download_string_file(~filename, ~content_type, ~contents); -}; - -let export_instructor_grading_report = (exercise: Exercise.state) => { - // .ml files because show uses OCaml syntax (dune handles seamlessly) - let module_name = exercise.eds.module_name; - let filename = exercise.eds.module_name ++ "_grading.ml"; - let content_type = "text/plain"; - let contents = Exercise.export_grading_module(module_name, exercise); - JsUtil.download_string_file(~filename, ~content_type, ~contents); -}; - -let instructor_exercise_update = - (model: Model.t, fn: Exercise.state => unit): Result.t(Model.t) => { - switch (model.editors) { - | Exercises(_, _, exercise) when model.settings.instructor_mode => - fn(exercise); - Ok(model); - | _ => Error(InstructorOnly) // TODO Make command palette contextual and figure out how to represent that here - }; -}; - -let ui_state_update = - (ui_state: Model.ui_state, update: set_meta, ~schedule_action as _) - : Model.ui_state => { - switch (update) { - | Mousedown => {...ui_state, mousedown: true} - | Mouseup => {...ui_state, mousedown: false} - | ShowBackpackTargets(b) => {...ui_state, show_backpack_targets: b} - | FontMetrics(font_metrics) => {...ui_state, font_metrics} - }; -}; - -let apply = (model: Model.t, update: t, ~schedule_action): Result.t(Model.t) => { - let perform_action = (model: Model.t, a: Action.t): Result.t(Model.t) => { - switch ( - Editors.perform_action(~settings=model.settings.core, model.editors, a) - ) { - | Error(err) => Error(err) - | Ok(editors) => Ok({...model, editors}) - }; - }; - let m: Result.t(Model.t) = - switch (update) { - | Startup => Ok(on_startup(~schedule_action, model)) - | Reset => Ok(Model.reset(model)) - | Set(Evaluation(_) as s_action) => Ok(update_settings(s_action, model)) - | Set(s_action) => - let model = update_settings(s_action, model); - Model.save(model); - switch (update) { - // NOTE: Load here necessary to load editors on switching mode - | Set(Mode(_)) => Ok(Model.load(model)) - | _ => Ok(model) - }; - | SetMeta(action) => - let ui_state = - ui_state_update(model.ui_state, action, ~schedule_action); - Ok({...model, ui_state}); - | UpdateExplainThisModel(u) => - let explainThisModel = - ExplainThisUpdate.set_update(model.explainThisModel, u); - Model.save_and_return({...model, explainThisModel}); - | DebugConsole(key) => - DebugConsole.print(model, key); - Ok(model); - | Save => - print_endline("Saving..."); - Model.save_and_return(model); - | InitImportAll(file) => - JsUtil.read_file(file, data => schedule_action(FinishImportAll(data))); - Ok(model); - | FinishImportAll(data) => - switch (data) { - | None => Ok(model) - | Some(data) => - Export.import_all(data, ~specs=ExerciseSettings.exercises); - Ok(Model.load(model)); - } - | InitImportScratchpad(file) => - JsUtil.read_file(file, data => - schedule_action(FinishImportScratchpad(data)) - ); - Ok(model); - | FinishImportScratchpad(data) => - let editors = - Editors.import_current( - ~settings=model.settings.core, - model.editors, - data, - ); - Model.save_and_return({...model, editors}); - | Export(ExportPersistentData) => - Model.save(model); - export_persistent_data(); - Ok(model); - | Export(ExportScratchSlide) => - Model.save(model); - let editor = Editors.get_editor(model.editors); - export_scratch_slide(editor); - Ok(model); - | Export(ExerciseModule) => - Model.save(model); - instructor_exercise_update(model, export_exercise_module); - | Export(Submission) => - Model.save(model); - export_submission(~instructor_mode=model.settings.instructor_mode); - Ok(model); - | Export(TransitionaryExerciseModule) => - Model.save(model); - instructor_exercise_update(model, export_transitionary); - | Export(GradingExerciseModule) => - Model.save(model); - instructor_exercise_update(model, export_instructor_grading_report); - | ResetCurrentEditor => - let instructor_mode = model.settings.instructor_mode; - let editors = - Editors.reset_current( - ~settings=model.settings.core, - model.editors, - ~instructor_mode, - ); - Model.save_and_return({...model, editors}); - | SwitchScratchSlide(n) => - let instructor_mode = model.settings.instructor_mode; - switch ( - switch_scratch_slide( - ~settings=model.settings.core, - model.editors, - ~instructor_mode, - n, - ) - ) { - | None => Error(FailedToSwitch) - | Some(editors) => Model.save_and_return({...model, editors}) - }; - | SwitchDocumentationSlide(name) => - switch (Editors.switch_example_slide(model.editors, name)) { - | None => Error(FailedToSwitch) - | Some(editors) => Model.save_and_return({...model, editors}) - } - | SwitchEditor(pos) => - let instructor_mode = model.settings.instructor_mode; - switch (switch_exercise_editor(model.editors, ~pos, ~instructor_mode)) { - | None => Error(FailedToSwitch) - | Some(editors) => Ok({...model, editors}) - }; - | TAB => - /* Attempt to act intelligently when TAB is pressed. - * TODO: Consider more advanced TAB logic. Instead - * of simply moving to next hole, if the backpack is non-empty - * but can't immediately put down, move to next position of - * interest, which is closet of: nearest position where can - * put down, farthest position where can put down, next hole */ - let z = Editors.get_editor(model.editors).state.zipper; - let action: Action.t = - Selection.is_buffer(z.selection) - ? Buffer(Accept) - : Zipper.can_put_down(z) - ? Put_down : Move(Goal(Piece(Grout, Right))); - perform_action(model, action); - | PerformAction(a) => - let r = perform_action(model, a); - r; - | Undo => - switch (Editors.update_opt(model.editors, Editor.undo)) { - | None => Error(CantUndo) - | Some(editors) => Ok({...model, editors}) - } - | Redo => - switch (Editors.update_opt(model.editors, Editor.redo)) { - | None => Error(CantRedo) - | Some(editors) => Ok({...model, editors}) - } - | Benchmark(Start) => - List.iter(schedule_action, Benchmark.actions_1); - Benchmark.start(); - Ok(model); - | Benchmark(Finish) => - Benchmark.finish(); - Ok(model); - | StepperAction(key, StepForward(idx)) => - let r = - model.results - |> ModelResults.find(key) - |> ModelResult.step_forward(idx); - Ok({...model, results: model.results |> ModelResults.add(key, r)}); - | StepperAction(key, StepBackward) => - let r = - model.results - |> ModelResults.find(key) - |> ModelResult.step_backward(~settings=model.settings.core.evaluation); - Ok({...model, results: model.results |> ModelResults.add(key, r)}); - | ToggleStepper(key) => - Ok({ - ...model, - results: - model.results - |> ModelResults.update(key, v => - Some( - v - |> Option.value(~default=NoElab: ModelResult.t) - |> ModelResult.toggle_stepper( - ~settings=model.settings.core.evaluation, - ), - ) - ), - }) - | UpdateResult(results) => - let results = - ModelResults.union((_, _a, b) => Some(b), model.results, results); - Ok({...model, results}); - }; - m |> Result.map(~f=update_cached_data(~schedule_action, update)); -}; diff --git a/src/haz3lweb/UpdateAction.re b/src/haz3lweb/UpdateAction.re deleted file mode 100644 index cd2f145f3e..0000000000 --- a/src/haz3lweb/UpdateAction.re +++ /dev/null @@ -1,269 +0,0 @@ -open Util; -open Haz3lcore; - -[@deriving (show({with_path: false}), sexp, yojson)] -type evaluation_settings_action = - | ShowRecord - | ShowCaseClauses - | ShowFnBodies - | ShowCasts - | ShowFixpoints - | ShowLookups - | ShowFilters - | ShowSettings - | ShowHiddenSteps; - -[@deriving (show({with_path: false}), sexp, yojson)] -type settings_action = - | Captions - | SecondaryIcons - | Statics - | Dynamics - | Assist - | Elaborate - | Benchmark - | ContextInspector - | InstructorMode - | Evaluation(evaluation_settings_action) - | ExplainThis(ExplainThisModel.Settings.action) - | Mode(Settings.mode); - -[@deriving (show({with_path: false}), sexp, yojson)] -type stepper_action = - | StepForward(int) - | StepBackward; - -[@deriving (show({with_path: false}), sexp, yojson)] -type set_meta = - | Mousedown - | Mouseup - | ShowBackpackTargets(bool) - | FontMetrics(FontMetrics.t); - -[@deriving (show({with_path: false}), sexp, yojson)] -type benchmark_action = - | Start - | Finish; - -[@deriving (show({with_path: false}), sexp, yojson)] -type export_action = - | ExportScratchSlide - | ExportPersistentData - | ExerciseModule - | Submission - | TransitionaryExerciseModule - | GradingExerciseModule; - -[@deriving (show({with_path: false}), sexp, yojson)] -type t = - /* meta */ - | Startup - | Reset - | Set(settings_action) - | SetMeta(set_meta) - | UpdateExplainThisModel(ExplainThisUpdate.update) - | Export(export_action) - | DebugConsole(string) - /* editors */ - | ResetCurrentEditor - | InitImportAll([@opaque] Js_of_ocaml.Js.t(Js_of_ocaml.File.file)) - | FinishImportAll(option(string)) - | SwitchEditor(Exercise.pos) //exercisemode only - | SwitchDocumentationSlide(string) //examplemode only - // editors: scratchmode only - | InitImportScratchpad([@opaque] Js_of_ocaml.Js.t(Js_of_ocaml.File.file)) - | FinishImportScratchpad(option(string)) - | SwitchScratchSlide(int) - /* editor */ - | TAB - | Save - | PerformAction(Action.t) - | Undo - | Redo - | Benchmark(benchmark_action) - | ToggleStepper(ModelResults.Key.t) - | StepperAction(ModelResults.Key.t, stepper_action) - | UpdateResult(ModelResults.t); - -module Failure = { - [@deriving (show({with_path: false}), sexp, yojson)] - type t = - | CantUndo - | CantRedo - | FailedToSwitch - | FailedToPerform(Action.Failure.t) - | InstructorOnly - | Exception(string); -}; - -module Result = { - include Result; - type t('success) = Result.t('success, Failure.t); -}; - -let is_edit: t => bool = - fun - | PerformAction(a) => Action.is_edit(a) - | Set(s_action) => - switch (s_action) { - | Mode(_) => true - | Captions - | SecondaryIcons - | Statics - | Assist - | Elaborate - | ExplainThis(_) - | Dynamics - | Benchmark - | ContextInspector - | InstructorMode - | Evaluation(_) => false - } - | SetMeta(meta_action) => - switch (meta_action) { - | Mousedown - | Mouseup - | ShowBackpackTargets(_) - | FontMetrics(_) => false - } - | Undo - | Redo - | SwitchScratchSlide(_) - | SwitchDocumentationSlide(_) - | ToggleStepper(_) - | StepperAction(_) - | FinishImportAll(_) - | FinishImportScratchpad(_) - | ResetCurrentEditor - | Reset - | TAB => true - | UpdateResult(_) - | SwitchEditor(_) - | Export(_) - | Save - | UpdateExplainThisModel(_) - | DebugConsole(_) - | InitImportAll(_) - | InitImportScratchpad(_) - | Benchmark(_) - | Startup => false; - -let reevaluate_post_update: t => bool = - fun - | PerformAction(a) => Action.is_edit(a) - | Set(s_action) => - switch (s_action) { - | Captions - | SecondaryIcons - | ContextInspector - | Benchmark - | ExplainThis(_) - | Evaluation( - ShowCaseClauses | ShowFnBodies | ShowCasts | ShowRecord | ShowFixpoints | - ShowLookups | - ShowFilters | - ShowSettings | - ShowHiddenSteps, - ) => - false - | Elaborate - | Statics - | Assist - | Dynamics - | InstructorMode - | Mode(_) => true - } - | SetMeta(meta_action) => - switch (meta_action) { - | Mousedown - | Mouseup - | ShowBackpackTargets(_) - | FontMetrics(_) => false - } - | Save - | InitImportAll(_) - | InitImportScratchpad(_) - | UpdateExplainThisModel(_) - | Export(_) - | UpdateResult(_) - | SwitchEditor(_) - | DebugConsole(_) - | Benchmark(_) => false - | TAB - | StepperAction(_, StepForward(_) | StepBackward) - | ToggleStepper(_) - | FinishImportAll(_) - | FinishImportScratchpad(_) - | ResetCurrentEditor - | SwitchScratchSlide(_) - | SwitchDocumentationSlide(_) - | Reset - | Undo - | Redo - | Startup => true; - -let should_scroll_to_caret = - fun - | Set(s_action) => - switch (s_action) { - | Mode(_) => true - | Captions - | SecondaryIcons - | Statics - | Assist - | Elaborate - | ExplainThis(_) - | Dynamics - | Benchmark - | ContextInspector - | InstructorMode - | Evaluation(_) => false - } - | SetMeta(meta_action) => - switch (meta_action) { - | FontMetrics(_) => true - | Mousedown - | Mouseup - | ShowBackpackTargets(_) => false - } - | UpdateResult(_) - | ToggleStepper(_) - | StepperAction(_, StepBackward | StepForward(_)) => false - | FinishImportScratchpad(_) - | FinishImportAll(_) - | ResetCurrentEditor - | SwitchEditor(_) - | SwitchScratchSlide(_) - | SwitchDocumentationSlide(_) - | Reset - | Undo - | Redo - | TAB - | Startup => true - | PerformAction(a) => - switch (a) { - | Move(_) - | Jump(_) - | Select(Resize(_) | Term(_) | Smart(_) | Tile(_)) - | Destruct(_) - | Insert(_) - | Pick_up - | Put_down - | RotateBackpack - | MoveToBackpackTarget(_) - | Buffer(Set(_) | Accept | Clear) - | Paste(_) - | Copy - | Cut - | Reparse => true - | Project(_) - | Unselect(_) - | Select(All) => false - } - | Save - | InitImportAll(_) - | InitImportScratchpad(_) - | UpdateExplainThisModel(_) - | Export(_) - | DebugConsole(_) - | Benchmark(_) => false; diff --git a/src/haz3lweb/Updated.re b/src/haz3lweb/Updated.re new file mode 100644 index 0000000000..c75569ec56 --- /dev/null +++ b/src/haz3lweb/Updated.re @@ -0,0 +1,33 @@ +type t('a) = { + model: 'a, + is_edit: bool, // Should the editor autosave after this action? + recalculate: bool, // Should the editor recalculate after this action? + scroll_active: bool, // Should the editor scroll to the cursor after this action? + logged: bool // Should this action be logged? +}; + +let ( let* ) = (updated: t('a), f) => { + {...updated, model: f(updated.model)}; +}; + +let return = + ( + ~is_edit=true, + ~recalculate=true, + ~scroll_active=true, + ~logged=true, + model: 'a, + ) => { + {model, is_edit, recalculate, scroll_active, logged}; +}; + +let return_quiet = + ( + ~is_edit=false, + ~recalculate=false, + ~scroll_active=false, + ~logged=false, + model: 'a, + ) => { + {model, is_edit, recalculate, scroll_active, logged}; +}; diff --git a/src/haz3lweb/app/Cursor.re b/src/haz3lweb/app/Cursor.re new file mode 100644 index 0000000000..9265d154fc --- /dev/null +++ b/src/haz3lweb/app/Cursor.re @@ -0,0 +1,35 @@ +type cursor('update) = { + info: option(Haz3lcore.Info.t), + selected_text: option(unit => string), + editor: option(Haz3lcore.Editor.t), + editor_read_only: bool, + editor_action: Haz3lcore.Action.t => option('update), + undo_action: option('update), + redo_action: option('update), +}; + +let map = (f: 'a => 'b, cursor) => { + ...cursor, + editor_action: x => x |> cursor.editor_action |> Option.map(f), + undo_action: cursor.undo_action |> Option.map(f), + redo_action: cursor.redo_action |> Option.map(f), +}; + +let map_opt = (f: 'a => option('b), cursor) => { + ...cursor, + editor_action: x => x |> cursor.editor_action |> Option.bind(_, f), + undo_action: cursor.undo_action |> Option.bind(_, f), + redo_action: cursor.redo_action |> Option.bind(_, f), +}; + +let empty = { + info: None, + selected_text: None, + editor: None, + editor_read_only: false, + editor_action: _ => None, + undo_action: None, + redo_action: None, +}; + +let (let+) = (cursor, f) => map(f, cursor); diff --git a/src/haz3lweb/Log.re b/src/haz3lweb/app/Log.re similarity index 76% rename from src/haz3lweb/Log.re rename to src/haz3lweb/app/Log.re index 7c87a640f6..c2b596cc14 100644 --- a/src/haz3lweb/Log.re +++ b/src/haz3lweb/app/Log.re @@ -2,33 +2,6 @@ open Util; -let is_action_logged: UpdateAction.t => bool = - fun - | SetMeta(_) - | Save - | InitImportAll(_) - | InitImportScratchpad(_) - | Export(_) - | FinishImportAll(_) - | FinishImportScratchpad(_) - | Benchmark(_) - | DebugConsole(_) - | Startup => false - | Reset - | TAB - | Set(_) - | SwitchScratchSlide(_) - | SwitchDocumentationSlide(_) - | SwitchEditor(_) - | ResetCurrentEditor - | PerformAction(_) - | Undo - | Redo - | UpdateResult(_) - | ToggleStepper(_) - | StepperAction(_, StepForward(_) | StepBackward) - | UpdateExplainThisModel(_) => true; - module DB = { open Ezjs_idb; @@ -73,7 +46,10 @@ module DB = { module Entry = { [@deriving (show({with_path: false}), yojson, sexp)] - type t = (Model.timestamp, UpdateAction.t); + type timestamp = float; + + [@deriving (show({with_path: false}), yojson, sexp)] + type t = (timestamp, Page.Update.t); [@deriving (show({with_path: false}), yojson, sexp)] type s = list(t); @@ -102,8 +78,8 @@ let import = (data: string): unit => } ); -let update = (action: UpdateAction.t): unit => - if (is_action_logged(action)) { +let update = (action: Page.Update.t, result: Updated.t('a)): unit => + if (result.logged) { Entry.save(Entry.mk(action)); }; diff --git a/src/haz3lweb/LogEntry.re b/src/haz3lweb/app/LogEntry.re similarity index 89% rename from src/haz3lweb/LogEntry.re rename to src/haz3lweb/app/LogEntry.re index bf7d9dfd59..3b3df0a529 100644 --- a/src/haz3lweb/LogEntry.re +++ b/src/haz3lweb/app/LogEntry.re @@ -1,7 +1,7 @@ open Util; [@deriving (show({with_path: false}), yojson, sexp)] -type t = (float, UpdateAction.t); +type t = (float, Page.Update.t); let mk = (update): t => { (JsUtil.timestamp(), update); @@ -16,7 +16,7 @@ let to_string = ((timestamp, update): t) => { Printf.sprintf( "%.0f: %s", timestamp, - UpdateAction.show(update), + Page.Update.show(update), //status, ); }; diff --git a/src/haz3lweb/FontMetrics.re b/src/haz3lweb/app/common/FontMetrics.re similarity index 100% rename from src/haz3lweb/FontMetrics.re rename to src/haz3lweb/app/common/FontMetrics.re diff --git a/src/haz3lweb/view/Icons.re b/src/haz3lweb/app/common/Icons.re similarity index 100% rename from src/haz3lweb/view/Icons.re rename to src/haz3lweb/app/common/Icons.re diff --git a/src/haz3lweb/view/ProjectorView.re b/src/haz3lweb/app/common/ProjectorView.re similarity index 55% rename from src/haz3lweb/view/ProjectorView.re rename to src/haz3lweb/app/common/ProjectorView.re index 1669ff136d..387ccc5cd7 100644 --- a/src/haz3lweb/view/ProjectorView.re +++ b/src/haz3lweb/app/common/ProjectorView.re @@ -77,7 +77,7 @@ let status = (indicated: option(Direction.t), selected: bool, shape: shape) => * adding fallthrough handlers where appropriate*/ let view_wrapper = ( - ~inject: UpdateAction.t => Ui_effect.t(unit), + ~inject: Action.t => Ui_effect.t(unit), ~font_metrics: FontMetrics.t, ~measurement: Measured.measurement, ~info: info, @@ -88,12 +88,7 @@ let view_wrapper = ) => { let shape = Projector.shape(p, info); let focus = (id, _) => - Effect.( - Many([ - Stop_propagation, - inject(PerformAction(Project(Focus(id, None)))), - ]) - ); + Effect.(Many([Stop_propagation, inject(Project(Focus(id, None)))])); div( ~attrs=[ Attr.classes( @@ -121,28 +116,28 @@ let handle = (id, action: external_action): Action.project => let setup_view = ( id: Id.t, - ~meta: Editor.Meta.t, - ~inject: UpdateAction.t => Ui_effect.t(unit), + ~cached_statics: CachedStatics.t, + ~cached_syntax: Editor.CachedSyntax.t, + ~inject: Action.t => Ui_effect.t(unit), ~font_metrics, ~indication: option(Direction.t), ) : option(Node.t) => { - let* p = Id.Map.find_opt(id, meta.syntax.projectors); + let* p = Id.Map.find_opt(id, cached_syntax.projectors); let* syntax = Some(p.syntax); - let ci = Id.Map.find_opt(id, meta.statics.info_map); + let ci = Id.Map.find_opt(id, cached_statics.info_map); let info = {id, ci, syntax}; - let+ measurement = Measured.find_pr_opt(p, meta.syntax.measured); + let+ measurement = Measured.find_pr_opt(p, cached_syntax.measured); let (module P) = to_module(p.kind); - let parent = a => inject(PerformAction(Project(handle(id, a)))); - let local = a => - inject(PerformAction(Project(SetModel(id, P.update(p.model, a))))); + let parent = a => inject(Project(handle(id, a))); + let local = a => inject(Project(SetModel(id, P.update(p.model, a)))); view_wrapper( ~inject, ~font_metrics, ~measurement, ~indication, ~info, - ~selected=List.mem(id, meta.syntax.selection_ids), + ~selected=List.mem(id, cached_syntax.selection_ids), p, P.view(p.model, ~info, ~local, ~parent), ); @@ -156,17 +151,36 @@ let indication = (z, id) => /* Returns a div containing all projector UIs, intended to * be absolutely positioned atop a rendered editor UI */ -let all = (z, ~meta: Editor.Meta.t, ~inject, ~font_metrics) => +let all = + ( + z, + ~cached_statics: CachedStatics.t, + ~cached_syntax: Editor.CachedSyntax.t, + ~inject, + ~font_metrics, + ) => { + // print_endline( + // "cardinal: " + // ++ (meta.projected.projectors |> Id.Map.cardinal |> string_of_int), + // ); div_c( "projectors", List.filter_map( ((id, _)) => { let indication = indication(z, id); - setup_view(id, ~meta, ~inject, ~font_metrics, ~indication); + setup_view( + id, + ~cached_statics, + ~cached_syntax, + ~inject, + ~font_metrics, + ~indication, + ); }, - Id.Map.bindings(meta.syntax.projectors) |> List.rev, + Id.Map.bindings(cached_syntax.projectors) |> List.rev, ), ); +}; /* When the caret is directly adjacent to a projector, keyboard commands * can be overidden here. Right now, trying to move into the projector, @@ -177,7 +191,7 @@ let all = (z, ~meta: Editor.Meta.t, ~inject, ~font_metrics) => * For example, without the modifiers check, this would break selection * around a projector. */ let key_handoff = (editor: Editor.t, key: Key.t): option(Action.project) => - switch (Editor.indicated_projector(editor)) { + switch (Editor.Model.indicated_projector(editor)) { | None => None | Some((id, p)) => let* (_, d, _) = Indicated.piece(editor.state.zipper); @@ -192,122 +206,3 @@ let key_handoff = (editor: Editor.t, key: Key.t): option(Action.project) => | _ => None }; }; - -/* The projector selection panel on the right of the bottom bar */ -module Panel = { - let option_view = (name, n) => - option( - ~attrs=n == name ? [Attr.create("selected", "selected")] : [], - [text(n)], - ); - - /* Decide which projectors are applicable based on the cursor info. - * This is slightly inside-out as elsewhere it depends on the underlying - * syntax, which is not easily available here */ - let applicable_projectors = (ci: Info.t): list(Base.kind) => - ( - switch (Info.cls_of(ci)) { - | Exp(Bool) - | Pat(Bool) => [Base.Checkbox] - | Exp(Int) - | Pat(Int) => [Slider] - | Exp(Float) - | Pat(Float) => [SliderF] - | Exp(String) - | Pat(String) => [TextArea] - | _ => [] - } - ) - @ [Base.Fold] - @ ( - switch (ci) { - | InfoExp(_) - | InfoPat(_) => [(Info: Base.kind)] - | _ => [] - } - ); - - let toggle_projector = (active, id, ci): Action.project => - active || applicable_projectors(ci) == [] - ? Remove(id) : SetIndicated(List.hd(applicable_projectors(ci))); - - let toggle_view = (~inject, ci, id, active: bool, might_project) => - div( - ~attrs=[ - clss( - ["toggle-switch"] - @ (active ? ["active"] : []) - @ (might_project ? [] : ["inactive"]), - ), - Attr.on_mousedown(_ => - might_project - ? inject(toggle_projector(active, id, ci)) : Effect.Ignore - ), - ], - [ - div( - ~attrs=[clss(["toggle-knob"])], - [ - Node.create( - "img", - ~attrs=[Attr.src("img/noun-fold-1593402.svg")], - [], - ), - ], - ), - ], - ); - - let kind = (editor: Editor.t) => { - let+ (_, p) = Editor.indicated_projector(editor); - p.kind; - }; - - let id = (editor: Editor.t) => { - switch (Editor.indicated_projector(editor)) { - | Some((id, _)) => id - | None => Id.invalid - }; - }; - - let currently_selected = editor => - option_view( - switch (kind(editor)) { - | None => "Fold" - | Some(k) => name(k) - }, - ); - - let view = (~inject, editor: Editor.t, ci: Info.t) => { - let might_project = - switch (Indicated.piece''(editor.state.zipper)) { - | Some((p, _, _)) => minimum_projection_condition(p) - | None => false - }; - let applicable_projectors = applicable_projectors(ci); - let should_show = might_project && applicable_projectors != []; - let select_view = - Node.select( - ~attrs=[ - Attr.on_change((_, name) => - inject(Action.SetIndicated(of_name(name))) - ), - ], - (might_project ? applicable_projectors : []) - |> List.map(name) - |> List.map(currently_selected(editor)), - ); - let toggle_view = - toggle_view( - ~inject, - ci, - id(editor), - kind(editor) != None, - might_project, - ); - div( - ~attrs=[Attr.id("projectors")], - (should_show ? [select_view] : []) @ [toggle_view], - ); - }; -}; diff --git a/src/haz3lweb/view/Widgets.re b/src/haz3lweb/app/common/Widgets.re similarity index 100% rename from src/haz3lweb/view/Widgets.re rename to src/haz3lweb/app/common/Widgets.re diff --git a/src/haz3lweb/app/editors/Editors.re b/src/haz3lweb/app/editors/Editors.re new file mode 100644 index 0000000000..fffd026843 --- /dev/null +++ b/src/haz3lweb/app/editors/Editors.re @@ -0,0 +1,376 @@ +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type mode = + | Scratch + | Documentation + | Exercises; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Scratch(ScratchMode.Model.t) + | Documentation(ScratchMode.Model.t) + | Exercises(ExercisesMode.Model.t); + + let mode_string: t => string = + fun + | Scratch(_) => "Scratch" + | Documentation(_) => "Documentation" + | Exercises(_) => "Exercises"; +}; + +module StoreMode = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = Model.mode; + let key = Store.Mode; + let default = (): Model.mode => Documentation; + }); + +module Store = { + let load = (~settings, ~instructor_mode) => { + let mode = StoreMode.load(); + switch (mode) { + | Scratch => + Model.Scratch( + ScratchMode.Store.load() |> ScratchMode.Model.unpersist(~settings), + ) + | Documentation => + Model.Documentation( + ScratchMode.StoreDocumentation.load() + |> ScratchMode.Model.unpersist_documentation(~settings), + ) + | Exercises => + Model.Exercises( + ExercisesMode.Store.load(~settings, ~instructor_mode) + |> ExercisesMode.Model.unpersist(~settings, ~instructor_mode), + ) + }; + }; + + let save = (~instructor_mode, model: Model.t) => { + switch (model) { + | Model.Scratch(m) => + StoreMode.save(Scratch); + ScratchMode.Store.save(ScratchMode.Model.persist(m)); + | Model.Documentation(m) => + StoreMode.save(Documentation); + ScratchMode.StoreDocumentation.save( + ScratchMode.Model.persist_documentation(m), + ); + | Model.Exercises(m) => + StoreMode.save(Exercises); + ExercisesMode.Store.save(~instructor_mode, m); + }; + }; +}; + +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | SwitchMode(Model.mode) + // Scratch & Documentation + | Scratch(ScratchMode.Update.t) + // Exercises + | Exercises(ExercisesMode.Update.t); + + let update = (~globals: Globals.t, ~schedule_action, action, model: Model.t) => { + switch (action, model) { + | (Scratch(action), Scratch(m)) => + let* scratch = + ScratchMode.Update.update( + ~schedule_action=a => schedule_action(Scratch(a)), + ~is_documentation=false, + ~settings=globals.settings, + action, + m, + ); + Model.Scratch(scratch); + | (Scratch(action), Documentation(m)) => + let* scratch = + ScratchMode.Update.update( + ~settings=globals.settings, + ~schedule_action=a => schedule_action(Scratch(a)), + ~is_documentation=true, + action, + m, + ); + Model.Documentation(scratch); + | (Exercises(action), Exercises(m)) => + let* exercises = + ExercisesMode.Update.update( + ~globals, + ~schedule_action=a => schedule_action(Exercises(a)), + action, + m, + ); + Model.Exercises(exercises); + | (Scratch(_), Exercises(_)) + | (Exercises(_), Scratch(_)) + | (Exercises(_), Documentation(_)) => model |> return_quiet + | (SwitchMode(Scratch), Scratch(_)) + | (SwitchMode(Documentation), Documentation(_)) + | (SwitchMode(Exercises), Exercises(_)) => model |> return_quiet + | (SwitchMode(Scratch), _) => + Model.Scratch( + ScratchMode.Store.load() + |> ScratchMode.Model.unpersist(~settings=globals.settings.core), + ) + |> return + | (SwitchMode(Documentation), _) => + Model.Documentation( + ScratchMode.StoreDocumentation.load() + |> ScratchMode.Model.unpersist_documentation( + ~settings=globals.settings.core, + ), + ) + |> return + | (SwitchMode(Exercises), _) => + Model.Exercises( + ExercisesMode.Store.load( + ~settings=globals.settings.core, + ~instructor_mode=globals.settings.instructor_mode, + ) + |> ExercisesMode.Model.unpersist( + ~settings=globals.settings.core, + ~instructor_mode=globals.settings.instructor_mode, + ), + ) + |> return + }; + }; + + let calculate = (~settings, ~is_edited, ~schedule_action, model) => { + switch (model) { + | Model.Scratch(m) => + Model.Scratch( + ScratchMode.Update.calculate( + ~schedule_action=a => schedule_action(Scratch(a)), + ~settings, + ~is_edited, + m, + ), + ) + | Model.Documentation(m) => + Model.Documentation( + ScratchMode.Update.calculate( + ~schedule_action=a => schedule_action(Scratch(a)), + ~settings, + ~is_edited, + m, + ), + ) + | Model.Exercises(m) => + Model.Exercises( + ExercisesMode.Update.calculate( + ~schedule_action=a => schedule_action(Exercises(a)), + ~settings, + ~is_edited, + m, + ), + ) + }; + }; +}; + +module Selection = { + open Cursor; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Scratch(ScratchMode.Selection.t) + | Exercises(ExerciseMode.Selection.t); + + let get_cursor_info = (~selection: t, editors: Model.t): cursor(Update.t) => { + switch (selection, editors) { + | (Scratch(selection), Scratch(m)) => + let+ ci = ScratchMode.Selection.get_cursor_info(~selection, m); + Update.Scratch(ci); + | (Scratch(selection), Documentation(m)) => + let+ ci = ScratchMode.Selection.get_cursor_info(~selection, m); + Update.Scratch(ci); + | (Exercises(selection), Exercises(m)) => + let+ ci = ExercisesMode.Selection.get_cursor_info(~selection, m); + Update.Exercises(ci); + | (Scratch(_), Exercises(_)) + | (Exercises(_), Scratch(_)) + | (Exercises(_), Documentation(_)) => empty + }; + }; + + let handle_key_event = + (~selection: option(t), ~event, editors: Model.t): option(Update.t) => { + switch (selection, editors) { + | (Some(Scratch(selection)), Scratch(m)) => + ScratchMode.Selection.handle_key_event(~selection, ~event, m) + |> Option.map(x => Update.Scratch(x)) + | (Some(Scratch(selection)), Documentation(m)) => + ScratchMode.Selection.handle_key_event(~selection, ~event, m) + |> Option.map(x => Update.Scratch(x)) + | (Some(Exercises(selection)), Exercises(m)) => + ExercisesMode.Selection.handle_key_event(~selection, ~event, m) + |> Option.map(x => Update.Exercises(x)) + | (Some(Scratch(_)), Exercises(_)) + | (Some(Exercises(_)), Scratch(_)) + | (Some(Exercises(_)), Documentation(_)) + | (None, _) => None + }; + }; + + let jump_to_tile = + (~settings, tile, model: Model.t): option((Update.t, t)) => + switch (model) { + | Scratch(m) => + ScratchMode.Selection.jump_to_tile(tile, m) + |> Option.map(((x, y)) => (Update.Scratch(x), Scratch(y))) + | Documentation(m) => + ScratchMode.Selection.jump_to_tile(tile, m) + |> Option.map(((x, y)) => (Update.Scratch(x), Scratch(y))) + | Exercises(m) => + ExercisesMode.Selection.jump_to_tile(~settings, tile, m) + |> Option.map(((x, y)) => (Update.Exercises(x), Exercises(y))) + }; + + let default_selection = + fun + | Model.Scratch(_) => Scratch(MainEditor) + | Model.Documentation(_) => Scratch(MainEditor) + | Model.Exercises(_) => Exercises((Exercise.Prelude, MainEditor)); +}; + +module View = { + open Virtual_dom.Vdom; + open Node; + + type signal = + | MakeActive(Selection.t); + + let view = + ( + ~globals, + ~selection: option(Selection.t), + ~signal, + ~inject, + editors: Model.t, + ) => + switch (editors) { + | Scratch(m) => + ScratchMode.View.view( + ~signal= + fun + | MakeActive(s) => signal(MakeActive(Scratch(s))), + ~globals, + ~selected= + switch (selection) { + | Some(Scratch(s)) => Some(s) + | _ => None + }, + ~inject=a => Update.Scratch(a) |> inject, + m, + ) + | Documentation(m) => + ScratchMode.View.view( + ~signal= + fun + | MakeActive(s) => signal(MakeActive(Scratch(s))), + ~globals, + ~selected= + switch (selection) { + | Some(Scratch(s)) => Some(s) + | _ => None + }, + ~inject=a => Update.Scratch(a) |> inject, + m, + ) + | Exercises(m) => + ExercisesMode.View.view( + ~signal= + fun + | MakeActive(s) => signal(MakeActive(Exercises(s))), + ~globals, + ~selection= + switch (selection) { + | Some(Exercises(s)) => Some(s) + | _ => None + }, + ~inject=a => Update.Exercises(a) |> inject, + m, + ) + }; + + let file_menu = (~globals, ~inject, editors: Model.t) => + switch (editors) { + | Scratch(s) + | Documentation(s) => + ScratchMode.View.file_menu( + ~globals, + ~inject=x => inject(Update.Scratch(x)), + s, + ) + | Exercises(e) => + ExercisesMode.View.file_menu( + ~globals, + ~inject=x => inject(Update.Exercises(x)), + e, + ) + }; + + let top_bar = + (~globals: Globals.t, ~inject: Update.t => 'a, ~editors: Model.t) => { + let mode_menu = { + div( + ~attrs=[Attr.class_("mode-name"), Attr.title("Toggle Mode")], + [ + select( + ~attrs=[ + Attr.on_change(_ => + fun + | "Scratch" => inject(Update.SwitchMode(Scratch)) + | "Documentation" => inject(Update.SwitchMode(Documentation)) + | "Exercises" => inject(Update.SwitchMode(Exercises)) + | _ => failwith("Invalid mode") + ), + ], + List.map( + EditorModeView.option_view( + switch (editors) { + | Scratch(_) => "Scratch" + | Documentation(_) => "Documentation" + | Exercises(_) => "Exercises" + }, + ), + ["Scratch", "Documentation", "Exercises"], + ), + ), + ], + ); + }; + let contents = + switch (editors) { + | Scratch(m) => + ScratchMode.View.top_bar( + ~globals, + ~named_slides=false, + ~inject=a => Update.Scratch(a) |> inject, + m, + ) + | Documentation(m) => + ScratchMode.View.top_bar( + ~globals, + ~named_slides=true, + ~inject=a => Update.Scratch(a) |> inject, + m, + ) + | Exercises(m) => + ExercisesMode.View.top_bar( + ~globals, + ~inject=a => Update.Exercises(a) |> inject, + m, + ) + }; + div( + ~attrs=[Attr.id("editor-mode")], + [text("/"), mode_menu, text("/")] @ contents, + ); + }; +}; diff --git a/src/haz3lweb/app/editors/SettingsModal.re b/src/haz3lweb/app/editors/SettingsModal.re new file mode 100644 index 0000000000..f840948d7f --- /dev/null +++ b/src/haz3lweb/app/editors/SettingsModal.re @@ -0,0 +1,85 @@ +open Virtual_dom.Vdom; +open Node; +open Haz3lcore; + +let view = + ( + ~inject: Settings.Update.t => Ui_effect.t(unit), + settings: CoreSettings.Evaluation.t, + ) => { + let modal = div(~attrs=[Attr.class_("settings-modal")]); + let setting = (icon, name, current, action: Settings.Update.t) => + div( + ~attrs=[Attr.class_("settings-toggle")], + [ + Widgets.toggle(~tooltip=name, icon, current, _ => inject(action)), + text(name), + ], + ); + [ + modal([ + div( + ~attrs=[Attr.class_("settings-modal-top")], + [ + Widgets.button(Icons.thin_x, _ => inject(Evaluation(ShowSettings))), + ], + ), + setting( + "h", + "show full step trace", + settings.stepper_history, + Evaluation(ShowRecord), + ), + setting( + "|", + "show case clauses", + settings.show_case_clauses, + Evaluation(ShowCaseClauses), + ), + setting( + "λ", + "show function bodies", + settings.show_fn_bodies, + Evaluation(ShowFnBodies), + ), + setting( + "x", + "show fixpoints", + settings.show_fixpoints, + Evaluation(ShowFixpoints), + ), + setting( + Unicode.castArrowSym, + "show casts", + settings.show_casts, + Evaluation(ShowCasts), + ), + // Disabled until we have a way to print closures + // setting( + // "🔍", + // "show lookup steps", + // settings.show_lookup_steps, + // Evaluation(ShowLookups), + // ), + setting( + "⏯️", + "show stepper filters", + settings.show_stepper_filters, + Evaluation(ShowFilters), + ), + setting( + "🤫", + "show hidden steps", + settings.show_hidden_steps, + Evaluation(ShowHiddenSteps), + ), + ]), + div( + ~attrs=[ + Attr.class_("modal-back"), + Attr.on_mousedown(_ => inject(Evaluation(ShowSettings))), + ], + [], + ), + ]; +}; diff --git a/src/haz3lweb/app/editors/cell/CellCommon.re b/src/haz3lweb/app/editors/cell/CellCommon.re new file mode 100644 index 0000000000..1865974ca7 --- /dev/null +++ b/src/haz3lweb/app/editors/cell/CellCommon.re @@ -0,0 +1,44 @@ +open Virtual_dom.Vdom; +open Node; + +/* Helpers for creating cell ui components - mostly used by exercise mode */ + +let narrative_cell = (content: Node.t) => + div( + ~attrs=[Attr.class_("cell")], + [div(~attrs=[Attr.class_("cell-chapter")], [content])], + ); + +let simple_cell_item = (content: list(Node.t)) => + div(~attrs=[Attr.classes(["cell-item"])], content); + +let caption = (~rest: option(string)=?, bolded: string) => + div( + ~attrs=[Attr.classes(["cell-caption"])], + [strong([text(bolded)])] @ (rest |> Option.map(text) |> Option.to_list), + ); + +let simple_cell_view = (items: list(t)) => + div(~attrs=[Attr.class_("cell")], items); + +let report_footer_view = content => { + div(~attrs=[Attr.classes(["cell-item", "cell-report"])], content); +}; + +let panel = (~classes=[], content, ~footer: option(t)) => { + simple_cell_view( + [ + div(~attrs=[Attr.classes(["cell-item", "panel"] @ classes)], content), + ] + @ Option.to_list(footer), + ); +}; + +let title_cell = title => { + simple_cell_view([ + div( + ~attrs=[Attr.class_("title-cell")], + [div(~attrs=[Attr.class_("title-text")], [text(title)])], + ), + ]); +}; diff --git a/src/haz3lweb/app/editors/cell/CellEditor.re b/src/haz3lweb/app/editors/cell/CellEditor.re new file mode 100644 index 0000000000..d3b7ca5b97 --- /dev/null +++ b/src/haz3lweb/app/editors/cell/CellEditor.re @@ -0,0 +1,197 @@ +open Haz3lcore; +open Virtual_dom.Vdom; +open Node; + +/* A "Cell" with user-editable text at the top, and evaluation results at the bottom. */ +// This file follows conventions in [docs/ui-architecture.md] + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + editor: CodeEditable.Model.t, + result: EvalResult.Model.t, + }; + + let mk = editor => { + editor: { + editor, + statics: CachedStatics.empty, + }, + result: EvalResult.Model.init, + }; + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = CodeEditable.Model.persistent; + + let persist = model => model.editor |> CodeEditable.Model.persist; + let unpersist = (~settings as _, pz) => + pz |> PersistentZipper.unpersist |> Editor.Model.mk |> mk; +}; + +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | MainEditor(CodeEditable.Update.t) + | ResultAction(EvalResult.Update.t); + + let update = (~settings, action, model: Model.t) => { + switch (action) { + | MainEditor(action) => + let* editor = + CodeEditable.Update.update(~settings, action, model.editor); + {...model, editor}; + | ResultAction(action) => + let* result = + EvalResult.Update.update( + ~settings={ + ...settings, + core: { + ...settings.core, + assist: false, + }, + }, + action, + model.result, + ); + {...model, result}; + }; + }; + + let calculate = + ( + ~settings, + ~is_edited, + ~queue_worker, + ~stitch, + {editor, result}: Model.t, + ) + : Model.t => { + let editor = + CodeEditable.Update.calculate(~settings, ~is_edited, ~stitch, editor); + let result = + EvalResult.Update.calculate( + ~settings={...settings, assist: false}, + ~queue_worker, + ~is_edited, + editor |> CodeEditable.Model.get_statics, + result, + ); + {editor, result}; + }; +}; + +module Selection = { + open Cursor; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | MainEditor + | Result(EvalResult.Selection.t); + + let get_cursor_info = (~selection, model: Model.t): cursor(Update.t) => { + switch (selection) { + | MainEditor => + let+ ci = + CodeEditable.Selection.get_cursor_info(~selection=(), model.editor); + Update.MainEditor(ci); + | Result(selection) => + let+ ci = + EvalResult.Selection.get_cursor_info(~selection, model.result); + Update.ResultAction(ci); + }; + }; + + let handle_key_event = + (~selection, ~event, model: Model.t): option(Update.t) => { + switch (selection) { + | MainEditor => + CodeEditable.Selection.handle_key_event( + ~selection=(), + model.editor, + event, + ) + |> Option.map(x => Update.MainEditor(x)) + | Result(selection) => + EvalResult.Selection.handle_key_event(~selection, model.result, ~event) + |> Option.map(x => Update.ResultAction(x)) + }; + }; + + let jump_to_tile = (tile, model: Model.t): option((Update.t, t)) => { + CodeEditable.Selection.jump_to_tile(tile, model.editor) + |> Option.map(x => (Update.MainEditor(x), MainEditor)); + }; +}; + +module View = { + type event = + | MakeActive(Selection.t); + + let view = + ( + ~globals: Globals.t, + ~signal: event => Ui_effect.t(unit), + ~inject: Update.t => Ui_effect.t(unit), + ~selected: option(Selection.t), + ~caption: option(Node.t)=?, + ~sort=?, + ~result_kind=?, + ~locked=false, + model: Model.t, + ) => { + let (footer, overlays) = + EvalResult.View.view( + ~globals={ + ...globals, + settings: { + ...globals.settings, + core: { + ...globals.settings.core, + assist: false, + }, + }, + }, + ~signal= + fun + | MakeActive(a) => signal(MakeActive(Result(a))) + | JumpTo(id) => + Effect.Many([ + signal(MakeActive(MainEditor)), + inject(MainEditor(Perform(Jump(TileId(id))))), + ]), + ~inject=a => inject(ResultAction(a)), + ~selected={ + switch (selected) { + | Some(Result(a)) => Some(a) + | _ => None + }; + }, + ~result_kind?, + ~locked, + model.result, + ); + div( + ~attrs=[Attr.classes(["cell", locked ? "locked" : "unlocked"])], + Option.to_list(caption) + @ [ + CodeEditable.View.view( + ~globals, + ~signal= + locked + ? _ => Ui_effect.Ignore + : fun + | MakeActive => signal(MakeActive(MainEditor)), + ~inject= + locked + ? _ => Ui_effect.Ignore + : (action => inject(MainEditor(action))), + ~selected=selected == Some(MainEditor), + ~overlays=overlays(model.editor.editor), + ~sort?, + model.editor, + ), + ] + @ footer, + ); + }; +}; diff --git a/src/haz3lweb/view/Code.re b/src/haz3lweb/app/editors/code/Code.re similarity index 87% rename from src/haz3lweb/view/Code.re rename to src/haz3lweb/app/editors/code/Code.re index 608c6fad09..ee0cd2b564 100644 --- a/src/haz3lweb/view/Code.re +++ b/src/haz3lweb/app/editors/code/Code.re @@ -4,6 +4,8 @@ open Haz3lcore; open Util; open Util.Web; +/* Helpers for rendering code text with holes and syntax highlighting */ + let of_delim' = Core.Memo.general( ~cache_size_bound=10000, @@ -84,7 +86,7 @@ module Text = ( M: { let map: Measured.t; - let settings: Settings.t; + let settings: Settings.Model.t; let info_map: Statics.Map.t; }, ) => { @@ -175,36 +177,12 @@ let simple_view = (~font_metrics, ~segment, ~settings: Settings.t): Node.t => { ); }; -let of_hole = (~font_metrics, ~measured, g: Grout.t) => +let of_hole = (~globals: Globals.t, ~measured, g: Grout.t) => // TODO(d) fix sort EmptyHoleDec.view( - ~font_metrics, + ~font_metrics=globals.font_metrics, { measurement: Measured.find_g(~msg="Code.of_hole", g, measured), mold: Mold.of_grout(g, Any), }, ); - -let view = - ( - ~sort: Sort.t, - ~font_metrics, - ~settings: Settings.t, - z: Zipper.t, - {syntax: {measured, segment, holes, selection_ids, _}, statics, _}: Editor.Meta.t, - ) - : Node.t => { - module Text = - Text({ - let map = measured; - let settings = settings; - let info_map = statics.info_map; - }); - let buffer_ids = Selection.is_buffer(z.selection) ? selection_ids : []; - let code = Text.of_segment(buffer_ids, false, sort, segment); - let holes = List.map(of_hole(~measured, ~font_metrics), holes); - div( - ~attrs=[Attr.class_("code")], - [span_c("code-text", code), ...holes], - ); -}; diff --git a/src/haz3lweb/app/editors/code/CodeEditable.re b/src/haz3lweb/app/editors/code/CodeEditable.re new file mode 100644 index 0000000000..e90635a3ee --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeEditable.re @@ -0,0 +1,285 @@ +open Js_of_ocaml; +open Haz3lcore; +open Virtual_dom.Vdom; +type editor_id = string; +open Util; + +/* A selectable editable code container component with statics and type-directed code completion. */ +// This file follows conventions in [docs/ui-architecture.md] + +module Model = CodeWithStatics.Model; + +module Update = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Perform(Action.t) + | Undo + | Redo + | TAB + | DebugConsole(string); + + exception CantReset; + + let update = + (~settings: Settings.t, action: t, model: Model.t): Updated.t(Model.t) => { + let perform = (action, model: Model.t) => + Editor.Update.update( + ~settings=settings.core, + action, + model.statics, + model.editor, + ) + |> ( + fun + | Ok(editor) => Model.{editor, statics: model.statics} + | Error(err) => raise(Action.Failure.Exception(err)) + ) + |> Updated.return( + ~is_edit=Action.is_edit(action), + ~recalculate=true, + ~scroll_active={ + switch (action) { + | Move(_) + | Jump(_) + | Select(Resize(_) | Term(_) | Smart(_) | Tile(_)) + | Destruct(_) + | Insert(_) + | Pick_up + | Put_down + | RotateBackpack + | MoveToBackpackTarget(_) + | Buffer(Set(_) | Accept | Clear) + | Paste(_) + | Copy + | Cut + | Reparse => true + | Project(_) + | Unselect(_) + | Select(All) => false + }; + }, + ); + switch (action) { + | Perform(action) => perform(action, model) + | Undo => + switch (Editor.Update.undo(model.editor)) { + | Some(editor) => Model.{...model, editor} |> Updated.return + | None => model |> Updated.return_quiet + } + | Redo => + switch (Editor.Update.redo(model.editor)) { + | Some(editor) => Model.{...model, editor} |> Updated.return + | None => model |> Updated.return_quiet + } + | DebugConsole(key) => + DebugConsole.print(~settings, model, key); + model |> Updated.return_quiet; + | TAB => + /* Attempt to act intelligently when TAB is pressed. + * TODO: Consider more advanced TAB logic. Instead + * of simply moving to next hole, if the backpack is non-empty + * but can't immediately put down, move to next position of + * interest, which is closet of: nearest position where can + * put down, farthest position where can put down, next hole */ + let z = model.editor.state.zipper; + let action: Action.t = + Selection.is_buffer(z.selection) + ? Buffer(Accept) + : Zipper.can_put_down(z) + ? Put_down : Move(Goal(Piece(Grout, Right))); + perform(action, model); + }; + }; + + let calculate = CodeWithStatics.Update.calculate; +}; + +module Selection = { + open Cursor; + + // Editor selection is handled within Editor.t + [@deriving (show({with_path: false}), sexp, yojson)] + type t = unit; + + let get_cursor_info = (~selection as (), model: Model.t): cursor(Update.t) => { + { + ... + CodeWithStatics.Model.get_cursor_info(model) + |> map(x => Update.Perform(x)), + editor_read_only: false, + undo_action: Some(Update.Undo), + redo_action: Some(Update.Redo), + }; + }; + + let handle_key_event = + (~selection as (), _: Model.t): (Key.t => option(Update.t)) => + fun + | { + key: D("Z" | "z"), + sys: Mac, + shift: Down, + meta: Down, + ctrl: Up, + alt: Up, + } + | { + key: D("Z" | "z"), + sys: PC, + shift: Down, + meta: Up, + ctrl: Down, + alt: Up, + } => + Some(Update.Redo) + | {key: D("Tab"), sys: _, shift: Up, meta: Up, ctrl: Up, alt: Up} => + Some(Update.TAB) + | {key: D("Z" | "z"), sys: Mac, shift: Up, meta: Down, ctrl: Up, alt: Up} + | {key: D("Z" | "z"), sys: PC, shift: Up, meta: Up, ctrl: Down, alt: Up} => + Some(Update.Undo) + | {key: D(key), sys: Mac | PC, shift: Down, meta: Up, ctrl: Up, alt: Up} + when Keyboard.is_f_key(key) => + Some(Update.DebugConsole(key)) + | k => + Keyboard.handle_key_event(k) |> Option.map(x => Update.Perform(x)); + + let handle_key_event = (~selection, model: Model.t, key) => { + switch (ProjectorView.key_handoff(model.editor, key)) { + | Some(action) => Some(Update.Perform(Project(action))) + | None => handle_key_event(~selection, model, key) + }; + }; + + let jump_to_tile = (tile, model: Model.t) => { + switch (TileMap.find_opt(tile, model.editor.syntax.tiles)) { + | Some(_) => Some(Update.Perform(Jump(TileId(tile)))) + | None => None + }; + }; +}; + +module View = { + type event = + | MakeActive; + + let get_goal = + ( + ~font_metrics: FontMetrics.t, + text_box: Js.t(Dom_html.element), + e: Js.t(Dom_html.mouseEvent), + ) => { + let rect = text_box##getBoundingClientRect; + let goal_x = float_of_int(e##.clientX); + let goal_y = float_of_int(e##.clientY); + Point.{ + row: Float.to_int((goal_y -. rect##.top) /. font_metrics.row_height), + col: + Float.( + to_int(round((goal_x -. rect##.left) /. font_metrics.col_width)) + ), + }; + }; + + let mousedown_overlay = (~globals: Globals.t, ~inject) => + Node.div( + ~attrs= + Attr.[ + id("mousedown-overlay"), + on_mouseup(_ => globals.inject_global(SetMousedown(false))), + on_mousemove(e => { + let mouse_handler = + e##.target |> Js.Opt.get(_, _ => failwith("no target")); + let text_box = + JsUtil.get_child_with_class( + mouse_handler##.parentNode + |> Js.Opt.get(_, _ => failwith("")) + |> Js.Unsafe.coerce, + "code-container", + ) + |> Option.get; + let goal = + get_goal(~font_metrics=globals.font_metrics, text_box, e); + inject(Action.Select(Resize(Goal(Point(goal))))); + }), + ], + [], + ); + + let mousedown_handler = (~globals: Globals.t, ~signal, ~inject, evt) => { + let goal = + get_goal( + ~font_metrics=globals.font_metrics, + evt##.currentTarget + |> Js.Opt.get(_, _ => failwith("")) + |> JsUtil.get_child_with_class(_, "code-container") + |> Option.get, + evt, + ); + switch (JsUtil.ctrl_held(evt), JsUtil.num_clicks(evt)) { + | (true, _) => + Effect.Many([ + signal(MakeActive), + inject(Action.Move(Goal(Point(goal)))), + inject(Action.Jump(BindingSiteOfIndicatedVar)), + ]) + | (false, 1) => + /* Note that we only trigger drag mode (set mousedown) + * when the left mouse button (aka button 0) is pressed */ + Effect.Many( + ( + JsUtil.mouse_button(evt) == 0 + ? [globals.inject_global(SetMousedown(true))] : [] + ) + @ [signal(MakeActive), inject(Action.Move(Goal(Point(goal))))], + ) + | (false, n) => inject(Action.Select(Smart(n))) + }; + }; + + let view = + ( + ~globals: Globals.t, + ~signal: event => Ui_effect.t(unit), + ~inject: Update.t => Ui_effect.t(unit), + ~selected: bool, + ~overlays: list(Node.t)=[], + ~sort=?, + model: Model.t, + ) => { + let edit_decos = { + module Deco = + Deco.Deco({ + let editor = model.editor; + let globals = globals; + let statics = model.statics; + }); + Deco.editor(model.editor.state.zipper, selected); + }; + let projectors = + ProjectorView.all( + model.editor.state.zipper, + ~cached_statics=model.statics, + ~cached_syntax=model.editor.syntax, + ~inject=x => inject(Perform(x)), + ~font_metrics=globals.font_metrics, + ); + let overlays = edit_decos @ overlays @ [projectors]; + let code_view = + CodeWithStatics.View.view(~globals, ~overlays, ~sort?, model); + let mousedown_overlay = + selected && globals.mousedown + ? [mousedown_overlay(~globals, ~inject=x => inject(Perform(x)))] + : []; + let on_mousedown = + mousedown_handler(~globals, ~signal, ~inject=x => inject(Perform(x))); + Node.div( + ~attrs=[ + Attr.classes( + ["cell-item", "code-editor"] @ (selected ? ["selected"] : []), + ), + Attr.on_mousedown(on_mousedown), + ], + mousedown_overlay @ [code_view], + ); + }; +}; diff --git a/src/haz3lweb/app/editors/code/CodeSelectable.re b/src/haz3lweb/app/editors/code/CodeSelectable.re new file mode 100644 index 0000000000..5ee73cb496 --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeSelectable.re @@ -0,0 +1,82 @@ +open Haz3lcore; +open Util; + +/* A CodeEditor that's been restricted to only performing selection with + mouse/keyboard, no edits to the actual code. */ +// This file follows conventions in [docs/ui-architecture.md] + +module Model = CodeEditable.Model; + +module Update = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Move(Action.move) + | Jump(Action.jump_target) + | Select(Action.select) + | Unselect(option(Util.Direction.t)) + | Copy; + + let update = (~settings, action: t, model: Model.t): Updated.t(Model.t) => { + let action': CodeEditable.Update.t = + switch (action) { + | Move(move) => Perform(Move(move)) + | Jump(target) => Perform(Jump(target)) + | Select(select) => Perform(Select(select)) + | Unselect(dir) => Perform(Unselect(dir)) + | Copy => Perform(Copy) + }; + CodeEditable.Update.update(~settings, action', model); + }; + + let convert_action: CodeEditable.Update.t => option(t) = + fun + // These actions are allowed in a CodeSelectable + | Perform(Move(move)) => Some(Move(move)) + | Perform(Jump(target)) => Some(Jump(target)) + | Perform(Select(select)) => Some(Select(select)) + | Perform(Unselect(dir)) => Some(Unselect(dir)) + | Perform(Copy) => Some(Copy) + + // These actions are not allowed in a CodeSelectable + | Perform( + Destruct(_) | Insert(_) | RotateBackpack | MoveToBackpackTarget(_) | + Pick_up | + Put_down | + Paste(_) | + Reparse | + Cut | + Buffer(_) | + Project(_), + ) + | Undo + | Redo + | DebugConsole(_) + | TAB => None; + + let calculate = CodeEditable.Update.calculate; +}; + +module Selection = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = CodeEditable.Selection.t; + let get_cursor_info = (~selection, model) => + CodeEditable.Selection.get_cursor_info(~selection, model) + |> (ci => Cursor.{...ci, editor_read_only: true}) + |> Cursor.map_opt(Update.convert_action); + let handle_key_event = + (~selection, model: Model.t, key: Key.t): option(Update.t) => + CodeEditable.Selection.handle_key_event(~selection, model, key) + |> Option.bind(_, Update.convert_action); +}; + +module View = { + type event = CodeEditable.View.event; + + let view = (~inject: Update.t => 'a) => + CodeEditable.View.view(~inject=a => + switch (Update.convert_action(a)) { + | Some(action) => inject(action) + | None => Ui_effect.Ignore + } + ); +}; diff --git a/src/haz3lweb/app/editors/code/CodeViewable.re b/src/haz3lweb/app/editors/code/CodeViewable.re new file mode 100644 index 0000000000..ab789bdce0 --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeViewable.re @@ -0,0 +1,71 @@ +open Util.Web; +open Haz3lcore; + +/* Read-only code viewer, no interaction and no statics. All four + functions do the same thing but take differently-typed inputs. */ + +let view = + ( + ~globals: Globals.t, + ~sort: Sort.t, + ~measured, + ~buffer_ids, + ~segment, + ~holes, + ~info_map, + ) + : Node.t => { + module Text = + Code.Text({ + let map = measured; + let settings = globals.settings; + let info_map = info_map; + }); + let code = Text.of_segment(buffer_ids, false, sort, segment); + let holes = List.map(Code.of_hole(~measured, ~globals), holes); + div_c("code", [span_c("code-text", code), ...holes]); +}; + +// let view_editor = +// ( +// ~globals: Globals.t, +// ~sort: Sort.t, +// { +// state: +// { +// meta: {syntax: {measured, selection_ids, segment, holes, _}, _}, +// _, +// }, +// _, +// }: Editor.t, +// ) +// : Node.t => { +// view( +// ~globals, +// ~sort, +// ~measured, +// ~buffer_ids=selection_ids, +// ~segment, +// ~holes, +// ); +// }; + +let view_segment = + (~globals: Globals.t, ~sort: Sort.t, ~info_map, segment: Segment.t) => { + let measured = Measured.of_segment(segment, info_map); + let buffer_ids = []; + let holes = Segment.holes(segment); + view(~globals, ~sort, ~measured, ~buffer_ids, ~holes, ~segment, ~info_map); +}; + +let view_exp = (~globals: Globals.t, ~settings, exp: Exp.t) => { + exp + |> ExpToSegment.exp_to_segment(~settings) + |> view_segment(~globals, ~sort=Exp); +}; + +let view_typ = (~globals: Globals.t, ~settings, typ: Typ.t) => { + typ + |> ExpToSegment.typ_to_segment(~settings) + |> view_segment(~globals, ~sort=Typ); +}; diff --git a/src/haz3lweb/app/editors/code/CodeWithStatics.re b/src/haz3lweb/app/editors/code/CodeWithStatics.re new file mode 100644 index 0000000000..6e017081f7 --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeWithStatics.re @@ -0,0 +1,104 @@ +open Util.Web; +open Haz3lcore; + +/* Read-only code viewer with statics, but no interaction. Notably, + since there is no interaction, the user can see that there is an + error but cannot select the error for more details. */ + +/* This file follows conventions in [docs/ui-architecture.md] */ + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + // Updated: + editor: Editor.t, + // Calculated: + statics: CachedStatics.t, + }; + + let mk = editor => {editor, statics: CachedStatics.empty}; + + let mk_from_exp = (~settings: CoreSettings.t, ~inline=false, term: Exp.t) => { + ExpToSegment.exp_to_segment( + term, + ~settings=ExpToSegment.Settings.of_core(~inline, settings), + ) + |> Zipper.unzip + |> Editor.Model.mk + |> mk; + }; + + let get_statics = (model: t) => model.statics; + + let get_cursor_info = (model: t): Cursor.cursor(Action.t) => { + info: Indicated.ci_of(model.editor.state.zipper, model.statics.info_map), + selected_text: + Some(() => Printer.to_string_selection(model.editor.state.zipper)), + editor: Some(model.editor), + editor_read_only: true, + editor_action: x => Some(x), + undo_action: None, + redo_action: None, + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = PersistentZipper.t; + let persist = (model: t) => + model.editor.state.zipper |> PersistentZipper.persist; + let unpersist = p => + p |> PersistentZipper.unpersist |> Editor.Model.mk |> mk; +}; + +module Update = { + // There are no events for a read-only editor + type t; + + /* Calculates the statics for the editor. */ + let calculate = + (~settings, ~is_edited, ~stitch, {editor, statics: _}: Model.t) + : Model.t => { + let statics = CachedStatics.init(~settings, ~stitch, editor.state.zipper); + let editor = + Editor.Update.calculate(~settings, ~is_edited, statics, editor); + {editor, statics}; + }; +}; + +module View = { + // There are no events for a read-only editor + type event; + + let view = + (~globals, ~overlays: list(Node.t)=[], ~sort=Sort.root, model: Model.t) => { + let { + statics: {info_map, _}, + editor: + { + syntax: {measured, selection_ids, segment, holes, _}, + state: {zipper: z, _}, + _, + }, + _, + }: Model.t = model; + let code_text_view = + CodeViewable.view( + ~globals, + ~sort, + ~measured, + ~buffer_ids=Selection.is_buffer(z.selection) ? selection_ids : [], + ~segment, + ~holes, + ~info_map, + ); + let statics_decos = { + module Deco = + Deco.Deco({ + let globals = globals; + let editor = model.editor; + let statics = model.statics; + }); + Deco.statics(); + }; + div_c("code-container", [code_text_view] @ statics_decos @ overlays); + }; +}; diff --git a/src/haz3lweb/view/BackpackView.re b/src/haz3lweb/app/editors/decoration/BackpackView.re similarity index 99% rename from src/haz3lweb/view/BackpackView.re rename to src/haz3lweb/app/editors/decoration/BackpackView.re index 3acdcb8c3f..1e8c93985e 100644 --- a/src/haz3lweb/view/BackpackView.re +++ b/src/haz3lweb/app/editors/decoration/BackpackView.re @@ -10,7 +10,7 @@ let text_view = (seg: Segment.t): list(Node.t) => { module Text = Code.Text({ let map = measured_of(seg); - let settings = Init.startup.settings; + let settings = Settings.Model.init; let info_map = Id.Map.empty; /* Assume this doesn't contain projectors */ }); Text.of_segment([], true, Any, seg); diff --git a/src/haz3lweb/view/dec/CaretDec.re b/src/haz3lweb/app/editors/decoration/CaretDec.re similarity index 100% rename from src/haz3lweb/view/dec/CaretDec.re rename to src/haz3lweb/app/editors/decoration/CaretDec.re diff --git a/src/haz3lweb/view/dec/CaretPosDec.re b/src/haz3lweb/app/editors/decoration/CaretPosDec.re similarity index 100% rename from src/haz3lweb/view/dec/CaretPosDec.re rename to src/haz3lweb/app/editors/decoration/CaretPosDec.re diff --git a/src/haz3lweb/view/dec/DecUtil.re b/src/haz3lweb/app/editors/decoration/DecUtil.re similarity index 95% rename from src/haz3lweb/view/dec/DecUtil.re rename to src/haz3lweb/app/editors/decoration/DecUtil.re index d4d3492946..f07f095be5 100644 --- a/src/haz3lweb/view/dec/DecUtil.re +++ b/src/haz3lweb/app/editors/decoration/DecUtil.re @@ -128,6 +128,7 @@ let code_svg_sized = ~measurement: Haz3lcore.Measured.measurement, ~base_cls=[], ~path_cls=[], + ~attr=[], ~fudge: fdims=fzero, paths: list(SvgUtil.Path.cmd), ) => { @@ -135,12 +136,17 @@ let code_svg_sized = let d = absolute ? d : {left: 0, top: 0, width: d.width, height: d.height}; create_svg( "svg", - ~attrs=[ - Attr.classes(base_cls), - Attr.create("style", pos_str(~d, ~fudge, font_metrics)), - Attr.create("viewBox", Printf.sprintf("0 0 %d %d", d.width, d.height)), - Attr.create("preserveAspectRatio", "none"), - ], + ~attrs= + [ + Attr.classes(base_cls), + Attr.create("style", pos_str(~d, ~fudge, font_metrics)), + Attr.create( + "viewBox", + Printf.sprintf("0 0 %d %d", d.width, d.height), + ), + Attr.create("preserveAspectRatio", "none"), + ] + @ attr, [SvgUtil.Path.view(~attrs=[Attr.classes(path_cls)], paths)], ); }; diff --git a/src/haz3lweb/view/Deco.re b/src/haz3lweb/app/editors/decoration/Deco.re similarity index 70% rename from src/haz3lweb/view/Deco.re rename to src/haz3lweb/app/editors/decoration/Deco.re index a616fe9eb0..7512696ed7 100644 --- a/src/haz3lweb/view/Deco.re +++ b/src/haz3lweb/app/editors/decoration/Deco.re @@ -1,4 +1,3 @@ -open Virtual_dom.Vdom; open Util; open Util.Web; open Haz3lcore; @@ -180,23 +179,28 @@ module HighlightSegment = module Deco = ( M: { - let ui_state: Model.ui_state; - let meta: Editor.Meta.t; - let highlights: option(ColorSteps.colorMap); + let globals: Globals.t; + let editor: Editor.t; + let statics: CachedStatics.t; }, ) => { - module Highlight = - HighlightSegment({ - let measured = M.meta.syntax.measured; - let info_map = M.meta.statics.info_map; - let font_metrics = M.ui_state.font_metrics; - }); - let font_metrics = M.ui_state.font_metrics; + let font_metrics = M.globals.font_metrics; + let map = M.editor.syntax.measured; + let show_backpack_targets = M.globals.show_backpack_targets; + let terms = M.editor.syntax.terms; + let term_ranges = M.editor.syntax.term_ranges; + let tiles = M.editor.syntax.tiles; + let measured = M.editor.syntax.measured; + let rows = measured.rows; + let projectors = M.editor.syntax.projectors; + let error_ids = M.statics.error_ids; + let color_highlights = M.globals.color_highlights; + let segment = M.editor.syntax.segment; - let tile = id => Id.Map.find(id, M.meta.syntax.tiles); + let tile = id => Id.Map.find(id, tiles); let caret = (z: Zipper.t): Node.t => { - let origin = Zipper.caret_point(M.meta.syntax.measured, z); + let origin = Zipper.caret_point(map, z); let shape = Zipper.caret_direction(z); let side = switch (Indicated.piece(z)) { @@ -210,6 +214,12 @@ module Deco = }; CaretDec.view(~font_metrics, ~profile={side, origin, shape}); }; + module Highlight = + HighlightSegment({ + let measured = M.editor.syntax.measured; + let info_map = M.statics.info_map; + let font_metrics = font_metrics; + }); let segment_selected = (z: Zipper.t) => Highlight.go( @@ -219,25 +229,22 @@ module Deco = ); let term_range = (p): option((Point.t, Point.t)) => { - let id = Any.rep_id(Id.Map.find(Piece.id(p), M.meta.syntax.terms)); - switch (TermRanges.find_opt(id, M.meta.syntax.term_ranges)) { + let id = Any.rep_id(Id.Map.find(Piece.id(p), terms)); + switch (TermRanges.find_opt(id, term_ranges)) { | None => None | Some((p_l, p_r)) => - let l = - Measured.find_p(~msg="Dec.range", p_l, M.meta.syntax.measured).origin; - let r = - Measured.find_p(~msg="Dec.range", p_r, M.meta.syntax.measured).last; + let l = Measured.find_p(~msg="Dec.range", p_l, measured).origin; + let r = Measured.find_p(~msg="Dec.range", p_r, measured).last; Some((l, r)); }; }; let all_tiles = (p: Piece.t): list((Uuidm.t, Mold.t, Measured.Shards.t)) => - Id.Map.find(Piece.id(p), M.meta.syntax.terms) + Id.Map.find(Piece.id(p), terms) |> Any.ids |> List.map(id => { let t = tile(id); - let shards = - Measured.find_shards(~msg="all_tiles", t, M.meta.syntax.measured); + let shards = Measured.find_shards(~msg="all_tiles", t, measured); (id, t.mold, shards); }); @@ -247,7 +254,7 @@ module Deco = | None => [] | Some((Grout(_), _, _)) => [] | Some((Projector(p), _, _)) => - switch (Measured.find_pr_opt(p, M.meta.syntax.measured)) { + switch (Measured.find_pr_opt(p, M.editor.syntax.measured)) { | Some(measurement) => [ PieceDec.simple_shard_indicated( { @@ -280,8 +287,9 @@ module Deco = | Some(range) => let tiles = all_tiles(p); PieceDec.indicated( + ~line_clss=[], ~font_metrics, - ~rows=M.meta.syntax.measured.rows, + ~rows, ~caret=(Piece.id(p), index), ~tiles, range, @@ -310,20 +318,10 @@ module Deco = switch (Siblings.neighbors((l, r))) { | (None, None) => failwith("impossible") | (_, Some(p)) => - let m = - Measured.find_p( - ~msg="Deco.targets", - p, - M.meta.syntax.measured, - ); + let m = Measured.find_p(~msg="Deco.targets", p, measured); Measured.{origin: m.origin, last: m.origin}; | (Some(p), _) => - let m = - Measured.find_p( - ~msg="Deco.targets", - p, - M.meta.syntax.measured, - ); + let m = Measured.find_p(~msg="Deco.targets", p, measured); Measured.{origin: m.last, last: m.last}; }; let profile = CaretPosDec.Profile.{style: `Sibling, measurement}; @@ -352,35 +350,33 @@ module Deco = let backpack = (z: Zipper.t): Node.t => BackpackView.view( ~font_metrics, - ~origin=Zipper.caret_point(M.meta.syntax.measured, z), + ~origin=Zipper.caret_point(measured, z), z, ); let backpack_targets = (backpack, seg) => div_c( "backpack-targets", - M.ui_state.show_backpack_targets && Backpack.restricted(backpack) + show_backpack_targets && Backpack.restricted(backpack) ? targets(backpack, seg) : [], ); let term_decoration = (~id: Id.t, deco: ((Point.t, Point.t, SvgUtil.Path.t)) => Node.t) => { - let (p_l, p_r) = TermRanges.find(id, M.meta.syntax.term_ranges); - let l = - Measured.find_p(~msg="Deco.term", p_l, M.meta.syntax.measured).origin; - let r = - Measured.find_p(~msg="Deco.term", p_r, M.meta.syntax.measured).last; + let (p_l, p_r) = TermRanges.find(id, term_ranges); + let l = Measured.find_p(~msg="Deco.term", p_l, measured).origin; + let r = Measured.find_p(~msg="Deco.term", p_r, measured).last; open SvgUtil.Path; let r_edge = ListUtil.range(~lo=l.row, r.row + 1) |> List.concat_map(i => { - let row = Measured.Rows.find(i, M.meta.syntax.measured.rows); + let row = Measured.Rows.find(i, measured.rows); [h(~x=i == r.row ? r.col : row.max_col), v_(~dy=1)]; }); let l_edge = ListUtil.range(~lo=l.row, r.row + 1) |> List.rev_map(i => { - let row = Measured.Rows.find(i, M.meta.syntax.measured.rows); + let row = Measured.Rows.find(i, measured.rows); [h(~x=i == l.row ? l.col : row.indent), v_(~dy=-1)]; }) |> List.concat; @@ -419,7 +415,7 @@ module Deco = List.map( ((id, color)) => term_highlight(~clss=["highlight-code-" ++ color], id), - switch (M.highlights) { + switch (color_highlights) { | Some(colorMap) => ColorSteps.to_list(colorMap) | _ => [] }, @@ -428,11 +424,11 @@ module Deco = let error_view = (id: Id.t) => try( - switch (Id.Map.find_opt(id, M.meta.syntax.projectors)) { + switch (Id.Map.find_opt(id, projectors)) { | Some(p) => /* Special case for projectors as they are not in tile map */ let shapes = ProjectorBase.shapes(p); - let measurement = Id.Map.find(id, M.meta.syntax.measured.projectors); + let measurement = Id.Map.find(id, measured.projectors); div_c( "errors-piece", [ @@ -454,11 +450,17 @@ module Deco = |> List.flatten; switch (term_range(p)) { | Some(range) => - let rows = M.meta.syntax.measured.rows; + let rows = measured.rows; let decos = shard_decos - @ PieceDec.uni_lines(~font_metrics, ~rows, range, tiles) - @ PieceDec.bi_lines(~font_metrics, ~rows, tiles); + @ PieceDec.uni_lines( + ~font_metrics, + ~rows, + range, + tiles, + ~line_clss=[], + ) + @ PieceDec.bi_lines(~font_metrics, ~rows, tiles, ~line_clss=[]); div_c("errors-piece", decos); | None => div_c("errors-piece", shard_decos) }; @@ -472,8 +474,7 @@ module Deco = Node.div([]) }; - let errors = () => - div_c("errors", List.map(error_view, M.meta.statics.error_ids)); + let errors = () => div_c("errors", List.map(error_view, error_ids)); let indication = (z: Zipper.t) => div_c("indication", indicated_piece_deco(z)); @@ -482,13 +483,101 @@ module Deco = let always = () => [errors()]; - let all = z => [ - caret(z), - indication(z), - selection(z), - backpack(z), - backpack_targets(z.backpack, M.meta.syntax.segment), - errors(), - color_highlights(), - ]; + let next_steps = (next_steps, ~inject) => { + let tiles = List.filter_map(TileMap.find_opt(_, tiles), next_steps); + List.mapi( + (i, t: Tile.t) => { + let id = Tile.id(t); + let mold = t.mold; + let shards = Measured.find_shards(t, map); + let range: option((Measured.Point.t, Measured.Point.t)) = { + // if (Piece.has_ends(p)) { + let id = Id.Map.find(id, terms) |> Any.rep_id; + switch (TermRanges.find_opt(id, term_ranges)) { + | None => None + | Some((p_l, p_r)) => + let l = Measured.find_p(p_l, map).origin; + let r = Measured.find_p(p_r, map).last; + Some((l, r)); + }; + }; + Option.map( + x => { + PieceDec.indicated( + ~base_clss="tile-next-step", + ~attr=[Virtual_dom.Vdom.Attr.on_mousedown(_ => {inject(i)})], + ~line_clss=["next-step-line"], + ~font_metrics, + ~caret=(Id.invalid, 0), + ~rows=measured.rows, + ~tiles=[(id, mold, shards)], + x, + ) + @ PieceDec.indicated( + ~base_clss="tile-next-step-top", + ~attr=[Virtual_dom.Vdom.Attr.on_mousedown(_ => {inject(i)})], + ~line_clss=["next-step-line"], + ~font_metrics, + ~caret=(Id.invalid, 0), + ~rows=measured.rows, + ~tiles=[(id, mold, shards)], + x, + ) + }, + range, + ); + }, + tiles, + ) + |> List.filter_map(x => x) + |> List.flatten; + }; + + let taken_steps = taken_steps => { + let tiles = List.filter_map(TileMap.find_opt(_, tiles), taken_steps); + List.mapi( + (_, t: Tile.t) => { + let id = Tile.id(t); + let mold = t.mold; + let shards = Measured.find_shards(t, map); + let range: option((Measured.Point.t, Measured.Point.t)) = { + // if (Piece.has_ends(p)) { + let id = Id.Map.find(id, terms) |> Any.rep_id; + switch (TermRanges.find_opt(id, term_ranges)) { + | None => None + | Some((p_l, p_r)) => + let l = Measured.find_p(p_l, map).origin; + let r = Measured.find_p(p_r, map).last; + Some((l, r)); + }; + }; + PieceDec.indicated( + ~base_clss="tile-taken-step", + ~line_clss=["taken-step-line"], + ~font_metrics, + ~caret=(Id.invalid, 0), + ~rows=measured.rows, + ~tiles=[(id, mold, shards)], + ) + |> Option.map(_, range); + }, + tiles, + ) + |> List.filter_map(x => x) + |> List.flatten; + }; + + let statics = () => [errors()]; + + let editor = (z, selected: bool) => + selected + ? [ + caret(z), + indication(z), + selection(z), + backpack(z), + backpack_targets(z.backpack, segment), + color_highlights(), + ] + : []; }; diff --git a/src/haz3lweb/view/dec/Diag.re b/src/haz3lweb/app/editors/decoration/Diag.re similarity index 100% rename from src/haz3lweb/view/dec/Diag.re rename to src/haz3lweb/app/editors/decoration/Diag.re diff --git a/src/haz3lweb/view/dec/EmptyHoleDec.re b/src/haz3lweb/app/editors/decoration/EmptyHoleDec.re similarity index 100% rename from src/haz3lweb/view/dec/EmptyHoleDec.re rename to src/haz3lweb/app/editors/decoration/EmptyHoleDec.re diff --git a/src/haz3lweb/view/dec/PieceDec.re b/src/haz3lweb/app/editors/decoration/PieceDec.re similarity index 89% rename from src/haz3lweb/view/dec/PieceDec.re rename to src/haz3lweb/app/editors/decoration/PieceDec.re index 4dc9465520..653ca3e0a7 100644 --- a/src/haz3lweb/view/dec/PieceDec.re +++ b/src/haz3lweb/app/editors/decoration/PieceDec.re @@ -16,6 +16,7 @@ let simple_shard = ( {font_metrics, tips: (l, r), measurement}: shard_dims, ~absolute=true, + ~attr=[], classes, ) : t => @@ -25,6 +26,7 @@ let simple_shard = ~base_cls=["shard"] @ classes, ~path_cls=[], ~absolute, + ~attr, DecUtil.shard_path( ( Option.map(Nib.Shape.direction_of(Left), l), @@ -43,18 +45,35 @@ let tips_of_shapes = ((l, r): (Nib.Shape.t, Nib.Shape.t)): (tip, tip) => ( Some(r), ); -let simple_shard_indicated = (shard_dims, ~sort: Sort.t, ~at_caret: bool): t => +let simple_shard_indicated = + ( + ~attr=?, + ~base_cls="indicated", + shard_dims, + ~sort: Sort.t, + ~at_caret: bool, + ) + : t => simple_shard( + ~attr?, shard_dims, - ["indicated", Sort.to_string(sort)] @ (at_caret ? ["caret"] : []), + [base_cls, Sort.to_string(sort)] @ (at_caret ? ["caret"] : []), ); let simple_shards_indicated = - (~font_metrics: FontMetrics.t, (id, mold, shards), ~caret: (Id.t, int)) + ( + ~attr: option(list(Attr.t))=?, + ~base_cls=?, + ~font_metrics: FontMetrics.t, + ~caret: (Id.t, int), + (id, mold, shards), + ) : list(t) => List.map( - ((index, measurement)) => + ((index, measurement)) => { simple_shard_indicated( + ~attr?, + ~base_cls?, { font_metrics, measurement, @@ -62,7 +81,8 @@ let simple_shards_indicated = }, ~sort=mold.out, ~at_caret=caret == (id, index), - ), + ) + }, shards, ); @@ -122,6 +142,7 @@ let bi_lines = ( ~font_metrics: FontMetrics.t, ~rows: Measured.Rows.t, + ~line_clss: list(string), tiles: list((Id.t, Mold.t, Measured.Shards.t)), ) : list(t) => { @@ -179,7 +200,7 @@ let bi_lines = | [] => failwith("empty tile") | [(_, mold, _), ..._] => mold.out }; - let clss = ["child-line", Sort.to_string(s)]; + let clss = ["child-line", Sort.to_string(s)] @ line_clss; intra_lines @ inter_lines |> List.map(((origin, path)) => @@ -191,6 +212,7 @@ let uni_lines = ( ~font_metrics: FontMetrics.t, ~rows: Measured.Rows.t, + ~line_clss: list(string), (l: Measured.Point.t, r: Measured.Point.t), tiles: list((Id.t, Mold.t, Measured.Shards.t)), ) => { @@ -315,7 +337,7 @@ let uni_lines = | [] => failwith("empty tile") | [(_, mold, _), ..._] => mold.out }; - let clss = ["child-line", Sort.to_string(s)]; + let clss = ["child-line", Sort.to_string(s)] @ line_clss; l_line @ r_line |> List.map(((origin, path)) => @@ -325,14 +347,25 @@ let uni_lines = let indicated = ( + ~attr=?, ~font_metrics: FontMetrics.t, ~rows: Measured.Rows.t, ~caret, ~tiles, + ~line_clss: list(string), + ~base_clss=?, range, ) : list(Node.t) => { - List.concat_map(simple_shards_indicated(~font_metrics, ~caret), tiles) - @ uni_lines(~font_metrics, ~rows, range, tiles) - @ bi_lines(~font_metrics, ~rows, tiles); + List.concat_map( + simple_shards_indicated( + ~attr?, + ~font_metrics, + ~caret, + ~base_cls=?base_clss, + ), + tiles, + ) + @ uni_lines(~line_clss, ~font_metrics, ~rows, range, tiles) + @ bi_lines(~line_clss, ~font_metrics, ~rows, tiles); }; diff --git a/src/haz3lweb/app/editors/mode/ExercisesMode.re b/src/haz3lweb/app/editors/mode/ExercisesMode.re new file mode 100644 index 0000000000..669df2de2a --- /dev/null +++ b/src/haz3lweb/app/editors/mode/ExercisesMode.re @@ -0,0 +1,492 @@ +open Util; + +/* This file handles the pagenation of Exercise Mode, and switching between + exercises. ExerciseMode.re handles the actual exercise. */ + +/* This file follows conventions in [docs/ui-architecture.md] */ + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + current: int, + exercises: list(ExerciseMode.Model.t), + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = { + cur_exercise: Exercise.key, + exercise_data: list((Exercise.key, ExerciseMode.Model.persistent)), + }; + + let persist = (~instructor_mode, model): persistent => { + cur_exercise: + Exercise.key_of_state( + List.nth(model.exercises, model.current).editors, + ), + exercise_data: + List.map( + (exercise: ExerciseMode.Model.t) => + ( + Exercise.key_of_state(exercise.editors), + ExerciseMode.Model.persist(~instructor_mode, exercise), + ), + model.exercises, + ), + }; + + let unpersist = (~settings, ~instructor_mode, persistent: persistent) => { + let exercises = + List.map2( + ExerciseMode.Model.unpersist(~settings, ~instructor_mode), + persistent.exercise_data |> List.map(snd), + ExerciseSettings.exercises, + ); + let current = + ListUtil.findi_opt( + spec => Exercise.key_of(spec) == persistent.cur_exercise, + ExerciseSettings.exercises, + ) + |> Option.map(fst) + |> Option.value(~default=0); + {current, exercises}; + }; + + let get_current = (m: t) => List.nth(m.exercises, m.current); +}; + +module StoreExerciseKey = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = Exercise.key; + let default = () => + List.nth(ExerciseSettings.exercises, 0) |> Exercise.key_of; + let key = Store.CurrentExercise; + }); + +module Store = { + let keystring_of_key = key => { + key |> Exercise.sexp_of_key |> Sexplib.Sexp.to_string; + }; + + let save_exercise = (exercise: ExerciseMode.Model.t, ~instructor_mode) => { + let key = Exercise.key_of_state(exercise.editors); + let value = ExerciseMode.Model.persist(exercise, ~instructor_mode); + module S = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = ExerciseMode.Model.persistent; + let default = () => failwith("default should not be used in save"); + let key = Store.Exercise(key); + }); + S.save(value); + }; + + let init_exercise = (~settings, spec, ~instructor_mode) => { + let key = Exercise.key_of(spec); + let exercise = + ExerciseMode.Model.of_spec(spec, ~settings, ~instructor_mode); + save_exercise(exercise, ~instructor_mode); + StoreExerciseKey.save(key); + exercise; + }; + + let load_exercise = + (~settings, key, spec, ~instructor_mode): ExerciseMode.Model.persistent => { + module S = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = ExerciseMode.Model.persistent; + let default = () => + spec + |> ExerciseMode.Model.of_spec(~settings, ~instructor_mode) + |> ExerciseMode.Model.persist(~instructor_mode); + let key = Store.Exercise(key); + }); + S.load(); + }; + + let save = (model: Model.t, ~instructor_mode) => { + let exercise = List.nth(model.exercises, model.current); + let key = Exercise.key_of(exercise.editors); + save_exercise(exercise, ~instructor_mode); + StoreExerciseKey.save(key); + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type exercise_export = Model.persistent; + + let load = (~settings, ~instructor_mode): Model.persistent => { + let cur_exercise = StoreExerciseKey.load(); + let exercise_data = + List.map( + spec => { + let key = Exercise.key_of(spec); + (key, load_exercise(~settings, key, spec, ~instructor_mode)); + }, + ExerciseSettings.exercises, + ); + {cur_exercise, exercise_data}; + }; + + let export = (~settings, ~instructor_mode) => + { + cur_exercise: StoreExerciseKey.load(), + exercise_data: + List.map( + spec => { + let key = Exercise.key_of(spec); + (key, load_exercise(~settings, key, spec, ~instructor_mode)); + }, + ExerciseSettings.exercises, + ), + } + |> sexp_of_exercise_export + |> Sexplib.Sexp.to_string; + + let import = (~settings, data, ~specs, ~instructor_mode) => { + let exercise_export = + data |> Sexplib.Sexp.of_string |> exercise_export_of_sexp; + StoreExerciseKey.save(exercise_export.cur_exercise); + List.iter( + ((key, value)) => { + let n = + ListUtil.findi_opt(spec => Exercise.key_of(spec) == key, specs) + |> Option.get + |> fst; + let spec = List.nth(specs, n); + save_exercise( + value + |> ExerciseMode.Model.unpersist( + ~settings, + ~instructor_mode, + _, + spec, + ), + ~instructor_mode, + ); + }, + exercise_export.exercise_data, + ); + }; +}; + +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | SwitchExercise(int) + | Exercise(ExerciseMode.Update.t) + | ExportModule + | ExportSubmission + | ExportTransitionary + | ExportGrading; + + let export_exercise_module = (exercises: Model.t): unit => { + let exercise = Model.get_current(exercises); + let module_name = exercise.editors.module_name; + let filename = exercise.editors.module_name ++ ".ml"; + let content_type = "text/plain"; + let contents = + Exercise.export_module(module_name, {eds: exercise.editors}); + JsUtil.download_string_file(~filename, ~content_type, ~contents); + }; + + let export_submission = (~globals: Globals.t) => + globals.get_log_and(log => { + let data = + globals.export_all( + ~settings=globals.settings.core, + ~instructor_mode=globals.settings.instructor_mode, + ~log, + ); + JsUtil.download_json(ExerciseSettings.filename, data); + }); + + let export_transitionary = (exercises: Model.t) => { + let exercise = Model.get_current(exercises); + // .ml files because show uses OCaml syntax (dune handles seamlessly) + let module_name = exercise.editors.module_name; + let filename = exercise.editors.module_name ++ ".ml"; + let content_type = "text/plain"; + let contents = + Exercise.export_transitionary_module( + module_name, + {eds: exercise.editors}, + ); + JsUtil.download_string_file(~filename, ~content_type, ~contents); + }; + + let export_instructor_grading_report = (exercises: Model.t) => { + let exercise = Model.get_current(exercises); + // .ml files because show uses OCaml syntax (dune handles seamlessly) + let module_name = exercise.editors.module_name; + let filename = exercise.editors.module_name ++ "_grading.ml"; + let content_type = "text/plain"; + let contents = + Exercise.export_grading_module(module_name, {eds: exercise.editors}); + JsUtil.download_string_file(~filename, ~content_type, ~contents); + }; + + let update = + (~globals: Globals.t, ~schedule_action, action: t, model: Model.t) => { + switch (action) { + | Exercise(action) => + let current = List.nth(model.exercises, model.current); + let* new_current = + ExerciseMode.Update.update( + ~settings=globals.settings, + ~schedule_action, + action, + current, + ); + let new_exercises = + ListUtil.put_nth(model.current, new_current, model.exercises); + Model.{current: model.current, exercises: new_exercises}; + | SwitchExercise(n) => + Model.{current: n, exercises: model.exercises} |> return + | ExportModule => + Store.save(~instructor_mode=globals.settings.instructor_mode, model); + export_exercise_module(model); + model |> return_quiet; + | ExportSubmission => + Store.save(~instructor_mode=globals.settings.instructor_mode, model); + export_submission(~globals); + model |> return_quiet; + | ExportTransitionary => + Store.save(~instructor_mode=globals.settings.instructor_mode, model); + export_transitionary(model); + model |> return_quiet; + | ExportGrading => + Store.save(~instructor_mode=globals.settings.instructor_mode, model); + export_instructor_grading_report(model); + model |> return_quiet; + }; + }; + + let calculate = + (~settings, ~is_edited, ~schedule_action, model: Model.t): Model.t => { + let exercise = + ExerciseMode.Update.calculate( + ~settings, + ~is_edited, + ~schedule_action=a => schedule_action(Exercise(a)), + List.nth(model.exercises, model.current), + ); + Model.{ + current: model.current, + exercises: ListUtil.put_nth(model.current, exercise, model.exercises), + }; + }; +}; + +module Selection = { + open Cursor; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = ExerciseMode.Selection.t; + + let get_cursor_info = (~selection, model: Model.t): cursor(Update.t) => { + let+ ci = + ExerciseMode.Selection.get_cursor_info( + ~selection, + List.nth(model.exercises, model.current), + ); + Update.Exercise(ci); + }; + + let handle_key_event = (~selection, ~event, model: Model.t) => + ExerciseMode.Selection.handle_key_event( + ~selection, + ~event, + List.nth(model.exercises, model.current), + ) + |> Option.map(a => Update.Exercise(a)); + + let jump_to_tile = + (~settings, tile, model: Model.t): option((Update.t, t)) => + ExerciseMode.Selection.jump_to_tile( + ~settings, + tile, + List.nth(model.exercises, model.current), + ) + |> Option.map(((x, y)) => (Update.Exercise(x), y)); +}; + +module View = { + open Widgets; + open Js_of_ocaml; + + let view = (~globals: Globals.t, ~inject: Update.t => 'a, model: Model.t) => { + let current = List.nth(model.exercises, model.current); + ExerciseMode.View.view( + ~globals, + ~inject=a => inject(Update.Exercise(a)), + current, + ); + }; + + let file_menu = (~globals: Globals.t, ~inject: Update.t => 'a, _: Model.t) => { + let reset_button = + Widgets.button_named( + Icons.trash, + _ => { + let confirmed = + JsUtil.confirm( + "Are you SURE you want to reset this exercise? You will lose any existing code that you have written, and course staff have no way to restore it!", + ); + if (confirmed) { + inject(Exercise(ResetExercise)); + } else { + Virtual_dom.Vdom.Effect.Ignore; + }; + }, + ~tooltip="Reset Exercise", + ); + + let instructor_export = + Widgets.button_named( + Icons.export, + _ => inject(ExportModule), + ~tooltip="Export Exercise Module", + ); + + let instructor_transitionary_export = + Widgets.button_named( + Icons.export, + _ => {inject(ExportTransitionary)}, + ~tooltip="Export Transitionary Exercise Module", + ); + + let instructor_grading_export = + Widgets.button_named( + Icons.export, + _ => {inject(ExportGrading)}, + ~tooltip="Export Grading Exercise Module", + ); + + let export_submission = + Widgets.button_named( + Icons.star, + _ => inject(ExportSubmission), + ~tooltip="Export Submission", + ); + + let import_submission = + Widgets.file_select_button_named( + "import-submission", + Icons.import, + file => { + switch (file) { + | None => Virtual_dom.Vdom.Effect.Ignore + | Some(file) => globals.inject_global(InitImportAll(file)) + } + }, + ~tooltip="Import Submission", + ); + + let export_persistent_data = + button_named( + Icons.export, + _ => globals.inject_global(ExportPersistentData), + ~tooltip="Export All Persistent Data", + ); + + let reset_hazel = + button_named( + Icons.bomb, + _ => { + let confirmed = + JsUtil.confirm( + "Are you SURE you want to reset Hazel to its initial state? You will lose any existing code that you have written, and course staff have no way to restore it!", + ); + if (confirmed) { + JsUtil.clear_localstore(); + Dom_html.window##.location##reload; + }; + Virtual_dom.Vdom.Effect.Ignore; + }, + ~tooltip="Reset Hazel (LOSE ALL DATA)", + ); + + let reparse = + button_named( + Icons.backpack, + _ => globals.inject_global(ActiveEditor(Reparse)), + ~tooltip="Reparse Editor", + ); + + let file_group_exercises = () => + NutMenu.item_group( + ~inject, + "File", + [export_submission, import_submission], + ); + + let reset_group_exercises = () => + NutMenu.item_group( + ~inject, + "Reset", + [reset_button, reparse, reset_hazel], + ); + + let dev_group_exercises = () => + NutMenu.item_group( + ~inject, + "Developer Export", + [ + export_persistent_data, + instructor_export, + instructor_transitionary_export, + instructor_grading_export, + ], + ); + + if (globals.settings.instructor_mode) { + [ + file_group_exercises(), + reset_group_exercises(), + dev_group_exercises(), + ]; + } else { + [file_group_exercises(), reset_group_exercises()]; + }; + }; + + let instructor_toggle = (~inject, ~instructor_mode) => + ExerciseSettings.show_instructor + ? [ + Widgets.toggle( + "🎓", ~tooltip="Toggle Instructor Mode", instructor_mode, _ => + inject(Globals.Update.Set(InstructorMode)) + ), + ] + : []; + + let top_bar = (~globals: Globals.t, ~inject: Update.t => 'a, model: Model.t) => + instructor_toggle( + ~inject=globals.inject_global, + ~instructor_mode=globals.settings.instructor_mode, + ) + @ EditorModeView.view( + ~signal= + fun + | Previous => + inject( + Update.SwitchExercise( + model.current - 1 mod List.length(model.exercises), + ), + ) + | Next => + inject( + Update.SwitchExercise( + model.current + 1 mod List.length(model.exercises), + ), + ), + ~indicator= + EditorModeView.indicator_n( + model.current, + List.length(model.exercises), + ), + ); +}; diff --git a/src/haz3lweb/SlideContent.re b/src/haz3lweb/app/editors/mode/SlideContent.re similarity index 90% rename from src/haz3lweb/SlideContent.re rename to src/haz3lweb/app/editors/mode/SlideContent.re index 639f55dd70..d78433d054 100644 --- a/src/haz3lweb/SlideContent.re +++ b/src/haz3lweb/app/editors/mode/SlideContent.re @@ -1,6 +1,5 @@ open Virtual_dom.Vdom; open Node; -open Editors; let img = create("img"); let slide = (header, content) => @@ -23,7 +22,7 @@ let em = content => span(~attrs=[Attr.class_("em")], [text(content)]); let get_content = fun - | Documentation("Expressive Programming", _) => + | "Expressive Programming" => Some( slide( "Expressive Programming", @@ -51,7 +50,7 @@ let get_content = ], ), ) - | Documentation("Composing Expressions", _) => + | "Composing Expressions" => Some( slide( "Composing Expressions", @@ -96,7 +95,7 @@ let get_content = ], ), ) - | Documentation("Computing Equationally", _) => + | "Computing Equationally" => Some( slide( "Computing Equationally", @@ -120,7 +119,7 @@ let get_content = ], ), ) - | Documentation("Variables", _) => + | "Variables" => Some( slide( "Variables", @@ -153,7 +152,7 @@ let get_content = ], ), ) - | Documentation("Compositionality", _) => + | "Compositionality" => Some( slide( "Compositionality", @@ -164,7 +163,7 @@ let get_content = ], ), ) - | Documentation("Scope", _) => + | "Scope" => Some( slide( "Scope", @@ -179,7 +178,7 @@ let get_content = ], ), ) - | Documentation("Shadowing", _) => + | "Shadowing" => Some( slide( "Shadowing", @@ -201,7 +200,7 @@ let get_content = ], ), ) - | Documentation("Booleans and Types", _) => + | "Booleans and Types" => Some( slide( "Booleans and Types", @@ -256,7 +255,7 @@ let get_content = ], ), ) - | Documentation("Conditional Expressions", _) => + | "Conditional Expressions" => Some( slide( "Conditional Expressions", @@ -275,7 +274,7 @@ let get_content = ], ), ) - | Documentation("Functions", _) => + | "Functions" => Some( slide( "Functions", @@ -306,19 +305,17 @@ let get_content = ], ), ) - | Documentation("Tuples", _) => Some(slide("Tuples", [])) - | Documentation("Pattern Matching on Tuples", _) => + | "Tuples" => Some(slide("Tuples", [])) + | "Pattern Matching on Tuples" => Some(slide("Pattern Matching on Tuples", [])) - | Documentation("Recursion", _) => Some(slide("Recursion", [])) - | Documentation("Lists", _) => Some(slide("Lists", [])) - | Documentation("Pattern Matching on Lists", _) => + | "Recursion" => Some(slide("Recursion", [])) + | "Lists" => Some(slide("Lists", [])) + | "Pattern Matching on Lists" => Some(slide("Pattern Matching on Lists", [])) - | Documentation("Recursion on Lists: length", _) => + | "Recursion on Lists: length" => Some(slide("Recursion on Lists: length", [])) - | Documentation("Recursion on Lists: sum", _) => - Some(slide("Recursion on Lists: sum", [])) - | Documentation("Recursion on Lists: num_zeros", _) => + | "Recursion on Lists: sum" => Some(slide("Recursion on Lists: sum", [])) + | "Recursion on Lists: num_zeros" => Some(slide("Recursion on Lists: num_zeros", [])) - | Documentation("Higher-Order Functions", _) => - Some(slide("Higher-Order Functions", [])) + | "Higher-Order Functions" => Some(slide("Higher-Order Functions", [])) | _ => None; diff --git a/src/haz3lweb/app/editors/result/EvalResult.re b/src/haz3lweb/app/editors/result/EvalResult.re new file mode 100644 index 0000000000..81f0a04fd2 --- /dev/null +++ b/src/haz3lweb/app/editors/result/EvalResult.re @@ -0,0 +1,605 @@ +open Util; + +/* The result box at the bottom of a cell. This is either the TestResutls + kind where only a summary of test results is shown, or the EvalResults kind + where users can choose whether they want to use a single-stepper or see the + result of full evaluation. */ + +/* This file follows conventions in [docs/ui-architecture.md] */ + +module type Model = { + type t; +}; + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type result = + | NoElab + | Evaluation({ + elab: Haz3lcore.Exp.t, + result: + Calc.t( + Haz3lcore.ProgramResult.t( + (Haz3lcore.Exp.t, Haz3lcore.EvaluatorState.t), + ), + ), + cached_settings: Calc.saved(Haz3lcore.CoreSettings.t), + editor: Calc.saved((Haz3lcore.Exp.t, CodeSelectable.Model.t)), + }) + | Stepper(StepperView.Model.t); + + [@deriving (show({with_path: false}), sexp, yojson)] + type kind = + | Evaluation + | Stepper; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + kind, + result, + previous_tests: option(Haz3lcore.TestResults.t) // Stops test results from being cleared on update + }; + + let make_test_report = (model: t): option(Haz3lcore.TestResults.t) => + switch (model.result) { + | Evaluation({result: OldValue(ResultOk((_, state))), _}) + | Evaluation({result: NewValue(ResultOk((_, state))), _}) => + Some( + state + |> Haz3lcore.EvaluatorState.get_tests + |> Haz3lcore.TestResults.mk_results, + ) + | Stepper(s) => + Some( + s.history + |> StepperView.Model.get_state + |> Haz3lcore.EvaluatorState.get_tests + |> Haz3lcore.TestResults.mk_results, + ) + | Evaluation(_) + | NoElab => None + }; + + let init = {kind: Evaluation, result: NoElab, previous_tests: None}; + + let test_results = (model: t): option(Haz3lcore.TestResults.t) => + switch (model.result) { + | Evaluation({result: OldValue(ResultOk((_, state))), _}) + | Evaluation({result: NewValue(ResultOk((_, state))), _}) => + Some( + state + |> Haz3lcore.EvaluatorState.get_tests + |> Haz3lcore.TestResults.mk_results, + ) + | Stepper(s) => + Some( + s.history + |> StepperView.Model.get_state + |> Haz3lcore.EvaluatorState.get_tests + |> Haz3lcore.TestResults.mk_results, + ) + | Evaluation(_) + | NoElab => model.previous_tests + }; + + let get_elaboration = (model: t): option(Haz3lcore.Exp.t) => + switch (model.result) { + | Evaluation({elab, _}) => Some(elab) + | Stepper(s) => StepperView.Model.get_elaboration(s) + | _ => None + }; +}; + +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | ToggleStepper + | StepperAction(StepperView.Update.t) + | EvalEditorAction(CodeSelectable.Update.t) + | UpdateResult(Haz3lcore.ProgramResult.t(Haz3lcore.ProgramResult.inner)); + + // Update is meant to make minimal changes to the model, and calculate will do the rest. + let update = (~settings, action, model: Model.t): Updated.t(Model.t) => + switch (action, model) { + | (ToggleStepper, {kind: Stepper, _}) => + {...model, kind: Evaluation} |> Updated.return + | (ToggleStepper, {kind: Evaluation, _}) => + {...model, kind: Stepper} |> Updated.return + | (StepperAction(a), {result: Stepper(s), _}) => + let* stepper = StepperView.Update.update(~settings, a, s); + {...model, result: Stepper(stepper)}; + | (StepperAction(_), _) => model |> Updated.return_quiet + | ( + EvalEditorAction(a), + { + result: + Evaluation({ + elab, + result, + cached_settings, + editor: Calculated((exp, editor)), + }), + _, + }, + ) => + let* editor = CodeSelectable.Update.update(~settings, a, editor); + { + ...model, + result: + Evaluation({ + elab, + result, + cached_settings, + editor: Calculated((exp, editor)), + }), + }; + | (EvalEditorAction(_), _) => model |> Updated.return_quiet + | ( + UpdateResult(update), + {result: Evaluation({elab, editor, cached_settings, _}), _}, + ) => + { + ...model, + result: + Evaluation({ + elab, + result: + NewValue( + Haz3lcore.ProgramResult.map( + ({result: r, state: s}: Haz3lcore.ProgramResult.inner) => { + let exp = + Haz3lcore.ProgramResult.Result.unbox(r) + |> Haz3lcore.DHExp.replace_all_ids; + (exp, s); + }, + update, + ), + ), + editor, + cached_settings, + }), + } + |> (x => {...x, previous_tests: Model.test_results(x)}) + |> Updated.return + | (UpdateResult(_), _) => model |> Updated.return_quiet + }; + + let calculate = + ( + ~settings: Haz3lcore.CoreSettings.t, + ~queue_worker: option(Haz3lcore.Exp.t => unit), + ~is_edited: bool, + statics: Haz3lcore.CachedStatics.t, + model: Model.t, + ) => { + let elab = statics.elaborated; + let model = + switch (model.kind, model.result) { + // If elab hasn't changed, don't recalculate + | ( + Evaluation, + Evaluation({elab: elab', result, cached_settings, editor}), + ) + when Haz3lcore.Exp.fast_equal(elab, elab') => { + ...model, + result: Evaluation({elab, result, cached_settings, editor}), + } + // If elab has changed, recalculate + | (Evaluation, _) when settings.dynamics => + switch (queue_worker) { + | None => { + ...model, + result: + Evaluation({ + elab, + result: { + switch (WorkerServer.work(elab)) { + | Ok((r, state)) => + let exp = Haz3lcore.ProgramResult.Result.unbox(r); + NewValue(Haz3lcore.ProgramResult.ResultOk((exp, state))); + | Error(e) => + NewValue(Haz3lcore.ProgramResult.ResultFail(e)) + }; + }, + cached_settings: Pending, + editor: Pending, + }), + } + + | Some(queue_worker) => + queue_worker(elab); + { + ...model, + result: + Evaluation({ + elab, + result: NewValue(Haz3lcore.ProgramResult.ResultPending), + cached_settings: Pending, + editor: Pending, + }), + }; + } + | (Evaluation, _) => {...model, result: NoElab} + | (Stepper, Stepper(s)) => + let s' = StepperView.Update.calculate(~settings, elab, s); + {...model, result: Stepper(s')}; + | (Stepper, _) => + let s = + StepperView.Model.init() + |> StepperView.Update.calculate(~settings, elab); + {...model, result: Stepper(s)}; + }; + + // Calculate evaluation editor + switch (model.result) { + | Evaluation({elab, result, cached_settings, editor}) => + open Calc.Syntax; + let cached_settings = Calc.set(~eq=(==), settings, cached_settings); + let editor = + editor + |> Calc.map_saved(x => Calc.Calculated(x)) + |> { + let.calc settings = cached_settings + and.calc result = result; + switch (result) { + | ResultOk((exp, _state)) => + exp + |> ( + settings.evaluation.show_casts + ? (x => x) : Haz3lcore.DHExp.strip_casts + ) + |> CodeSelectable.Model.mk_from_exp(~settings) + |> (x => Calc.Calculated((exp, x))) + | ResultFail(_) => Pending + | ResultPending => Pending + | Off(_) => Pending + }; + }; + let editor = + editor + |> Calc.get_value + |> Calc.map_saved(((exp, editor)) => + CodeSelectable.Update.calculate( + ~settings, + ~stitch=_ => exp, + ~is_edited, + editor, + ) + |> (x => (exp, x)) + ) + |> (x => Calc.OldValue(x)); + { + ...model, + result: + Evaluation({ + elab, + result: Calc.make_old(result), + cached_settings: Calc.save(cached_settings), + editor: Calc.get_value(editor), + }), + }; + | _ => model + }; + }; +}; + +module Selection = { + open Cursor; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Evaluation(CodeSelectable.Selection.t) + | Stepper(StepperView.Selection.t); + + let get_cursor_info = (~selection: t, mr: Model.t): cursor(Update.t) => + switch (selection, mr.result) { + | (_, NoElab) => empty + | (Evaluation(selection), Evaluation({editor: Calculated(editor), _})) => + let+ ci = + CodeSelectable.Selection.get_cursor_info(~selection, editor |> snd); + Update.EvalEditorAction(ci); + | (Stepper(selection), Stepper(s)) => + let+ ci = StepperView.Selection.get_cursor_info(~selection, s); + Update.StepperAction(ci); + | (_, Evaluation(_)) => empty + | (_, Stepper(_)) => empty + }; + + let handle_key_event = + (~selection: t, ~event, mr: Model.t): option(Update.t) => + switch (selection, mr.result) { + | (_, NoElab) => None + | (Evaluation(selection), Evaluation({editor: Calculated(editor), _})) => + CodeSelectable.Selection.handle_key_event( + ~selection, + editor |> snd, + event, + ) + |> Option.map(x => Update.EvalEditorAction(x)) + | (Stepper(selection), Stepper(s)) => + StepperView.Selection.handle_key_event(~selection, s, ~event) + |> Option.map(x => Update.StepperAction(x)) + | (_, Evaluation(_)) => None + | (_, Stepper(_)) => None + }; +}; + +module View = { + open Virtual_dom.Vdom; + open Web.Node; + + type event = + | MakeActive(Selection.t) + | JumpTo(Haz3lcore.Id.t); + + let error_msg = (err: Haz3lcore.ProgramResult.error) => + switch (err) { + | EvaulatorError(err) => Haz3lcore.EvaluatorError.show(err) + | UnknownException(str) => str + | Timeout => "Evaluation timed out" + }; + + let status_of: Haz3lcore.ProgramResult.t('a) => string = + fun + | ResultPending => "pending" + | ResultOk(_) => "ok" + | ResultFail(_) => "fail" + | Off(_) => "off"; + + let live_eval = + ( + ~globals: Globals.t, + ~signal: event => Ui_effect.t(unit), + ~inject: Update.t => Ui_effect.t(unit), + ~selected, + ~locked, + elab: Haz3lcore.Exp.t, + result: + Haz3lcore.ProgramResult.t( + (Haz3lcore.Exp.t, Haz3lcore.EvaluatorState.t), + ), + editor: Calc.saved(('a, CodeSelectable.Model.t)), + ) => { + let editor = + switch (editor) { + | Calculated(editor) => editor |> snd + | _ => + elab + |> CodeSelectable.Model.mk_from_exp(~settings=globals.settings.core) + }; + let code_view = + CodeSelectable.View.view( + ~signal= + fun + | MakeActive => signal(MakeActive(Evaluation())), + ~inject=a => inject(EvalEditorAction(a)), + ~globals, + ~selected, + ~sort=Haz3lcore.Sort.root, + editor, + ); + let exn_view = + switch (result) { + | ResultFail(err) => [ + div( + ~attrs=[Attr.classes(["error-msg"])], + [text(error_msg(err))], + ), + ] + | _ => [] + }; + Node.( + div( + ~attrs=[Attr.classes(["cell-item", "cell-result"])], + exn_view + @ [ + div( + ~attrs=[Attr.classes(["status", status_of(result)])], + [ + div(~attrs=[Attr.classes(["spinner"])], []), + div(~attrs=[Attr.classes(["eq"])], [text("≡")]), + ], + ), + div( + ~attrs=[Attr.classes(["result", status_of(result)])], + [code_view], + ), + ] + @ ( + locked + ? [] + : [ + Widgets.toggle(~tooltip="Show Stepper", "s", false, _ => + inject(ToggleStepper) + ), + ] + ), + ) + ); + }; + + let footer = + ( + ~globals: Globals.t, + ~signal, + ~inject, + ~result: Model.t, + ~selected: option(Selection.t), + ~locked, + ) => + switch (result.result) { + | _ when !globals.settings.core.dynamics => [] + | NoElab => [] + | Evaluation({elab, result, editor, _}) => [ + live_eval( + ~globals, + ~signal, + ~inject, + ~selected=selected == Some(Evaluation()), + ~locked, + elab, + result |> Calc.get_value, + editor, + ), + ] + | Stepper(s) => + StepperView.View.view( + ~globals, + ~selection= + switch (selected) { + | Some(Stepper(s)) => Some(s) + | _ => None + }, + ~signal= + fun + | HideStepper => inject(ToggleStepper) + | JumpTo(id) => signal(JumpTo(id)) + | MakeActive(s) => signal(MakeActive(Stepper(s))), + ~inject=x => inject(StepperAction(x)), + ~read_only=locked, + s, + ) + }; + + let test_status_icon_view = + (~font_metrics, insts, ms: Haz3lcore.Measured.Shards.t): option(Node.t) => + switch (ms) { + | [(_, {origin: _, last}), ..._] => + let status = + insts + |> Haz3lcore.TestMap.joint_status + |> Haz3lcore.TestStatus.to_string; + let pos = DecUtil.abs_position(~font_metrics, last); + Some( + Node.div(~attrs=[Attr.classes(["test-result", status]), pos], []), + ); + | _ => None + }; + + let test_result_layer = + ( + ~font_metrics, + ~measured: Haz3lcore.Measured.t, + test_results: Haz3lcore.TestResults.t, + ) + : Web.Node.t => + Web.div_c( + "test-decos", + List.filter_map( + ((id, insts)) => + switch (Haz3lcore.Id.Map.find_opt(id, measured.tiles)) { + | Some(ms) => test_status_icon_view(~font_metrics, insts, ms) + | None => None + }, + test_results.test_map, + ), + ); + + type result_kind = + | NoResults + | TestResults + | EvalResults + | Custom(Node.t); + + let view = + ( + ~globals: Globals.t, + ~signal: event => Ui_effect.t(unit), + ~inject: Update.t => Ui_effect.t(unit), + ~selected: option(Selection.t), + ~result_kind=EvalResults, + ~locked: bool, + model: Model.t, + ) => + switch (result_kind) { + // Normal case: + | EvalResults when globals.settings.core.dynamics => + let result = + footer(~globals, ~signal, ~inject, ~result=model, ~selected, ~locked); + let test_overlay = (editor: Haz3lcore.Editor.t) => + switch (Model.test_results(model)) { + | Some(result) => [ + test_result_layer( + ~font_metrics=globals.font_metrics, + ~measured=editor.syntax.measured, + result, + ), + ] + | None => [] + }; + (result, test_overlay); + + // Just showing elaboration because evaluation is off: + | EvalResults when globals.settings.core.elaborate => + let result = [ + text("Evaluation disabled, showing elaboration:"), + switch (Model.get_elaboration(model)) { + | Some(elab) => + elab + |> Haz3lcore.ExpToSegment.( + exp_to_segment( + ~settings= + Settings.of_core(~inline=false, globals.settings.core), + ) + ) + |> CodeViewable.view_segment( + ~globals, + ~sort=Exp, + ~info_map=Haz3lcore.Id.Map.empty, + ) + | None => text("No elaboration found") + }, + ]; + (result, (_ => [])); + + // Not showing any results: + | EvalResults + | NoResults => ([], (_ => [])) + + | Custom(node) => ( + [node], + ( + (editor: Haz3lcore.Editor.t) => + switch (Model.test_results(model)) { + | Some(result) => [ + test_result_layer( + ~font_metrics=globals.font_metrics, + ~measured=editor.syntax.measured, + result, + ), + ] + | None => [] + } + ), + ) + + // Just showing test results (school mode) + | TestResults => + let test_results = Model.test_results(model); + let test_overlay = (editor: Haz3lcore.Editor.t) => + switch (Model.test_results(model)) { + | Some(result) => [ + test_result_layer( + ~font_metrics=globals.font_metrics, + ~measured=editor.syntax.measured, + result, + ), + ] + | None => [] + }; + ( + [ + CellCommon.report_footer_view([ + TestView.test_summary( + ~inject_jump=tile => signal(JumpTo(tile)), + ~test_results, + ), + ]), + ], + test_overlay, + ); + }; +}; + +let view = View.view; diff --git a/src/haz3lweb/app/editors/result/StepperEditor.re b/src/haz3lweb/app/editors/result/StepperEditor.re new file mode 100644 index 0000000000..7e3ba6e5c1 --- /dev/null +++ b/src/haz3lweb/app/editors/result/StepperEditor.re @@ -0,0 +1,90 @@ +open Util; +open Haz3lcore; + +/* This file follows conventions in [docs/ui-architecture.md] */ + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + // Updated + editor: CodeSelectable.Model.t, + // Read-only + taken_steps: list(Id.t), + next_steps: list(Id.t), + }; +}; + +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = CodeSelectable.Update.t; + + let update = (~settings, action, model: Model.t): Updated.t(Model.t) => { + let* editor = + CodeSelectable.Update.update(~settings, action, model.editor); + Model.{ + editor, + taken_steps: model.taken_steps, + next_steps: model.next_steps, + }; + }; + + let calculate = + ( + ~settings, + ~is_edited, + ~stitch, + {editor, taken_steps, next_steps}: Model.t, + ) + : Model.t => { + let editor = + CodeSelectable.Update.calculate(~settings, ~is_edited, ~stitch, editor); + {editor, taken_steps, next_steps}; + }; +}; + +module Selection = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = CodeSelectable.Selection.t; + + let get_cursor_info = CodeSelectable.Selection.get_cursor_info; + + let handle_key_event = CodeSelectable.Selection.handle_key_event; +}; + +module View = { + type event = + | MakeActive + | TakeStep(int); + + let view = + ( + ~globals: Globals.t, + ~signal: event => 'a, + ~overlays=[], + ~selected, + model: Model.t, + ) => { + let overlays = { + module Deco = + Deco.Deco({ + let editor = model.editor.editor; + let globals = globals; + let statics = model.editor.statics; + }); + overlays + @ Deco.taken_steps(model.taken_steps) + @ Deco.next_steps(model.next_steps, ~inject=x => signal(TakeStep(x))); + }; + CodeSelectable.View.view( + ~signal= + fun + | MakeActive => signal(MakeActive), + ~selected, + ~globals, + ~overlays, + model.editor, + ); + }; +}; diff --git a/src/haz3lweb/ColorSteps.re b/src/haz3lweb/app/explainthis/ColorSteps.re similarity index 92% rename from src/haz3lweb/ColorSteps.re rename to src/haz3lweb/app/explainthis/ColorSteps.re index fe82ab8d02..bfc67a5ecd 100644 --- a/src/haz3lweb/ColorSteps.re +++ b/src/haz3lweb/app/explainthis/ColorSteps.re @@ -1,3 +1,6 @@ +open Util; + +[@deriving (show({with_path: false}), sexp, yojson)] type colorMap = Haz3lcore.Id.Map.t(string); /*[@deriving sexp]*/ diff --git a/src/haz3lweb/explainthis/Example.re b/src/haz3lweb/app/explainthis/Example.re similarity index 100% rename from src/haz3lweb/explainthis/Example.re rename to src/haz3lweb/app/explainthis/Example.re diff --git a/src/haz3lweb/view/ExplainThis.re b/src/haz3lweb/app/explainthis/ExplainThis.re similarity index 94% rename from src/haz3lweb/view/ExplainThis.re rename to src/haz3lweb/app/explainthis/ExplainThis.re index a74a5187d8..8a499ee881 100644 --- a/src/haz3lweb/view/ExplainThis.re +++ b/src/haz3lweb/app/explainthis/ExplainThis.re @@ -29,7 +29,8 @@ let feedback_view = (message, up_active, up_action, down_active, down_action) => ); }; -let explanation_feedback_view = (~inject, group_id, form_id, model) => { +let explanation_feedback_view = + (~inject: ExplainThisUpdate.update => 'a, group_id, form_id, model) => { let (up_active, down_active) = switch ( ExplainThisModel.get_explanation_feedback(group_id, form_id, model) @@ -41,23 +42,20 @@ let explanation_feedback_view = (~inject, group_id, form_id, model) => { feedback_view( "This explanation is helpful", up_active, - _ => - inject( - UpdateAction.UpdateExplainThisModel( - ToggleExplanationFeedback(group_id, form_id, ThumbsUp), - ), - ), + _ => inject(ToggleExplanationFeedback(group_id, form_id, ThumbsUp)), down_active, - _ => - inject( - UpdateAction.UpdateExplainThisModel( - ToggleExplanationFeedback(group_id, form_id, ThumbsDown), - ), - ), + _ => inject(ToggleExplanationFeedback(group_id, form_id, ThumbsDown)), ); }; -let example_feedback_view = (~inject, group_id, form_id, example_id, model) => { +let example_feedback_view = + ( + ~inject: ExplainThisUpdate.update => 'a, + group_id, + form_id, + example_id, + model, + ) => { let (up_active, down_active) = switch ( ExplainThisModel.get_example_feedback( @@ -75,17 +73,11 @@ let example_feedback_view = (~inject, group_id, form_id, example_id, model) => { "This example is helpful", up_active, _ => - inject( - UpdateAction.UpdateExplainThisModel( - ToggleExampleFeedback(group_id, form_id, example_id, ThumbsUp), - ), - ), + inject(ToggleExampleFeedback(group_id, form_id, example_id, ThumbsUp)), down_active, _ => inject( - UpdateAction.UpdateExplainThisModel( - ToggleExampleFeedback(group_id, form_id, example_id, ThumbsDown), - ), + ToggleExampleFeedback(group_id, form_id, example_id, ThumbsDown), ), ); }; @@ -94,26 +86,26 @@ let code_node = text => Node.span(~attrs=[clss(["code"])], [Node.text(text)]); let highlight = - (~inject, msg: list(Node.t), id: Id.t, mapping: ColorSteps.t) + ( + ~globals: Globals.t, + ~inject as _: ExplainThisUpdate.update => 'a, + msg: list(Node.t), + id: Id.t, + mapping: ColorSteps.t, + ) : (Node.t, ColorSteps.t) => { let (c, mapping) = ColorSteps.get_color(id, mapping); let classes = clss(["highlight-" ++ c, "clickable"]); - let attrs = - switch (inject) { - | Some(inject) => [ - classes, - Attr.on_mouseenter(_ => - inject(UpdateAction.Set(ExplainThis(SetHighlight(Hover(id))))) - ), - Attr.on_mouseleave(_ => - inject(UpdateAction.Set(ExplainThis(SetHighlight(UnsetHover)))) - ), - Attr.on_click(_ => - inject(UpdateAction.PerformAction(Select(Term(Id(id, Left))))) - ), - ] - | None => [classes] - }; + let attrs = [ + classes, + Attr.on_mouseenter(_ => + globals.inject_global(Set(ExplainThis(SetHighlight(Hover(id))))) + ), + Attr.on_mouseleave(_ => + globals.inject_global(Set(ExplainThis(SetHighlight(UnsetHover)))) + ), + Attr.on_click(_ => globals.inject_global(JumpToTile(id))), + ]; (Node.span(~attrs, msg), mapping); }; @@ -125,7 +117,8 @@ let highlight = code: `code` italics: *word* */ -let mk_translation = (~inject, text: string): (list(Node.t), ColorSteps.t) => { +let mk_translation = + (~globals, ~inject, text: string): (list(Node.t), ColorSteps.t) => { let omd = Omd.of_string(text); //print_markdown(omd); @@ -154,7 +147,8 @@ let mk_translation = (~inject, text: string): (list(Node.t), ColorSteps.t) => { | Some(id) => id | None => Id.invalid }; - let (inner_msg, mapping) = highlight(~inject, d, id, mapping); + let (inner_msg, mapping) = + highlight(~globals, ~inject, d, id, mapping); (List.append(msg, [inner_msg]), mapping); | Omd.Emph(_, d) => let (d, mapping) = translate_inline(d, [], mapping, ~inject); @@ -209,17 +203,17 @@ let mk_translation = (~inject, text: string): (list(Node.t), ColorSteps.t) => { let mk_explanation = ( + ~globals, ~inject, - ~settings: Settings.t, group_id, form_id, text: string, model: ExplainThisModel.t, ) : (Node.t, ColorSteps.t) => { - let (msg, color_map) = mk_translation(~inject=Some(inject), text); + let (msg, color_map) = mk_translation(~globals, ~inject, text); let feedback = - settings.explainThis.show_feedback + globals.settings.explainThis.show_feedback ? [explanation_feedback_view(~inject, group_id, form_id, model)] : []; ( div([div(~attrs=[clss(["explanation-contents"])], msg)] @ feedback), @@ -229,25 +223,20 @@ let mk_explanation = let expander_deco = ( + ~globals as {font_metrics, _} as globals: Globals.t, ~docs: ExplainThisModel.t, - ~settings: Settings.t, ~inject, - ~ui_state: Model.ui_state, ~options: list((ExplainThisForm.form_id, Segment.t)), ~group: ExplainThisForm.group, ~doc: ExplainThisForm.form, + editor, ) => { module Deco = Deco.Deco({ - let ui_state = ui_state; - let meta = - Editor.Meta.init( - ~settings=CoreSettings.off, - Zipper.unzip(doc.syntactic_form), - ); - let highlights: option(ColorSteps.colorMap) = None; + let editor = editor; + let globals = globals; + let statics = CachedStatics.empty; }); - let Model.{font_metrics, _} = ui_state; switch (doc.expandable_id, List.length(options)) { | (None, _) | (_, 0 | 1) => div([]) @@ -285,15 +274,18 @@ let expander_deco = List.map( ((id: ExplainThisForm.form_id, segment: Segment.t)): Node.t => { let code_view = - Code.simple_view(~font_metrics, ~segment, ~settings); + CodeViewable.view_segment( + ~globals, + ~sort=Exp, + ~info_map=Id.Map.empty, + segment, + ); let classes = id == doc.id ? ["selected"] @ get_clss(segment) : get_clss(segment); let update_group_selection = _ => inject( - UpdateAction.UpdateExplainThisModel( - ExplainThisUpdate.UpdateGroupSelection(group.id, id), - ), + ExplainThisUpdate.UpdateGroupSelection(group.id, id), ); Node.div( ~attrs=[ @@ -326,9 +318,7 @@ let expander_deco = DecUtil.abs_position(~font_metrics, origin), Attr.on_click(_ => { inject( - UpdateAction.UpdateExplainThisModel( - ExplainThisUpdate.SpecificityOpen(!docs.specificity_open), - ), + ExplainThisUpdate.SpecificityOpen(!docs.specificity_open), ) }), ], @@ -342,9 +332,8 @@ let expander_deco = let example_view = ( + ~globals: Globals.t, ~inject, - ~ui_state, - ~settings: Settings.t, ~group_id, ~form_id, ~examples: list(ExplainThisForm.example), @@ -356,9 +345,9 @@ let example_view = div( ~attrs=[Attr.id("examples")], List.mapi( - (idx, {term, message, sub_id, _}: ExplainThisForm.example) => { + (_, {term, message, sub_id, _}: ExplainThisForm.example) => { let feedback = - settings.explainThis.show_feedback + globals.settings.explainThis.show_feedback ? [ example_feedback_view( ~inject, @@ -372,12 +361,25 @@ let example_view = div( ~attrs=[clss(["example"])], [ - Cell.locked( - ~segment=term, - ~target_id="example" ++ string_of_int(idx), - ~ui_state, - ~settings, - ~inject, + CellEditor.View.view( + ~globals, + ~signal=_ => Ui_effect.Ignore, + ~inject=_ => Ui_effect.Ignore, + ~selected=None, + ~caption=None, + ~locked=true, + { + term + |> Zipper.unzip + |> Editor.Model.mk + |> CellEditor.Model.mk + |> CellEditor.Update.calculate( + ~settings=globals.settings.core, + ~is_edited=true, + ~stitch=x => x, + ~queue_worker=None, + ); + }, ), div( ~attrs=[clss(["explanation"])], @@ -421,17 +423,16 @@ let rec bypass_parens_typ = (typ: Typ.t) => { }; }; -[@deriving (show({with_path: false}), sexp, yojson)] type message_mode = | MessageContent( - UpdateAction.t => Virtual_dom.Vdom.Effect.t(unit), - Model.ui_state, - Settings.t, + ExplainThisUpdate.update => Virtual_dom.Vdom.Effect.t(unit), + Globals.t, ) | Colorings; let get_doc = ( + ~globals: Globals.t, ~docs: ExplainThisModel.t, info: option(Statics.Info.t), mode: message_mode, @@ -459,10 +460,10 @@ let get_doc = | (_, None) => doc.explanation }; switch (mode) { - | MessageContent(inject, ui_state, settings) => + | MessageContent(inject, globals) => let (explanation, color_map) = mk_explanation( - ~settings, + ~globals, ~inject, group.id, doc.id, @@ -483,40 +484,47 @@ let get_doc = |> List.to_seq |> Id.Map.of_seq |> Option.some; + let editor = Editor.Model.mk(doc.syntactic_form |> Zipper.unzip); let expander_deco = expander_deco( + ~globals, ~docs, - ~settings, ~inject, - ~ui_state, ~options, ~group, ~doc, + editor, ); + let statics = CachedStatics.empty; + let highlight_deco = { + module Deco = + Deco.Deco({ + let editor = editor; + let globals = {...globals, color_highlights: highlights}; + let statics = statics; + }); + [Deco.color_highlights()]; + }; let syntactic_form_view = - Cell.locked_no_statics( - ~target_id="explainThisSyntacticForm", - ~inject, - ~ui_state, - ~segment=doc.syntactic_form, - ~highlights, - ~settings, + CodeWithStatics.View.view( + ~globals, + ~overlays=highlight_deco @ [expander_deco], ~sort, - ~expander_deco, + {editor, statics}, ); let example_view = example_view( + ~globals, ~inject, - ~ui_state, - ~settings, ~group_id=group.id, ~form_id=doc.id, ~examples=doc.examples, ~model=docs, ); - (syntactic_form_view, ([explanation], color_map), example_view); + ([syntactic_form_view], ([explanation], color_map), example_view); | Colorings => - let (_, color_map) = mk_translation(~inject=None, explanation_msg); + let (_, color_map) = + mk_translation(~globals, ~inject=_ => (), explanation_msg); ([], ([], color_map), []); }; }; @@ -2351,32 +2359,32 @@ let section = (~section_clss: string, ~title: string, contents: list(Node.t)) => ); let get_color_map = - (~settings: Settings.t, ~explainThisModel: ExplainThisModel.t, info) => - switch (settings.explainThis.highlight) { - | All when settings.explainThis.show => + (~globals: Globals.t, ~explainThisModel: ExplainThisModel.t, info) => + switch (globals.settings.explainThis.highlight) { + | All when globals.settings.explainThis.show => let (_, (_, (color_map, _)), _) = - get_doc(~docs=explainThisModel, info, Colorings); + get_doc(~globals, ~docs=explainThisModel, info, Colorings); Some(color_map); - | One(id) when settings.explainThis.show => + | One(id) when globals.settings.explainThis.show => let (_, (_, (color_map, _)), _) = - get_doc(~docs=explainThisModel, info, Colorings); + get_doc(~globals, ~docs=explainThisModel, info, Colorings); Some(Id.Map.filter((id', _) => id == id', color_map)); | _ => None }; let view = ( + ~globals: Globals.t, ~inject, - ~ui_state: Model.ui_state, - ~settings: Settings.t, ~explainThisModel: ExplainThisModel.t, info: option(Info.t), ) => { let (syn_form, (explanation, _), example) = get_doc( + ~globals, ~docs=explainThisModel, info, - MessageContent(inject, ui_state, settings), + MessageContent(inject, globals), ); div( ~attrs=[Attr.id("side-bar")], @@ -2390,15 +2398,17 @@ let view = Widgets.toggle( ~tooltip="Toggle highlighting", "🔆", - settings.explainThis.highlight == All, + globals.settings.explainThis.highlight == All, _ => - inject(UpdateAction.Set(ExplainThis(SetHighlight(Toggle)))) + globals.inject_global( + Set(ExplainThis(SetHighlight(Toggle))), + ) ), div( ~attrs=[ clss(["close"]), Attr.on_click(_ => - inject(UpdateAction.Set(ExplainThis(ToggleShow))) + globals.inject_global(Set(ExplainThis(ToggleShow))) ), ], [Icons.thin_x], diff --git a/src/haz3lweb/explainthis/ExplainThisForm.re b/src/haz3lweb/app/explainthis/ExplainThisForm.re similarity index 100% rename from src/haz3lweb/explainthis/ExplainThisForm.re rename to src/haz3lweb/app/explainthis/ExplainThisForm.re diff --git a/src/haz3lweb/explainthis/ExplainThisModel.re b/src/haz3lweb/app/explainthis/ExplainThisModel.re similarity index 94% rename from src/haz3lweb/explainthis/ExplainThisModel.re rename to src/haz3lweb/app/explainthis/ExplainThisModel.re index 92ab95a342..e5496b7a37 100644 --- a/src/haz3lweb/explainthis/ExplainThisModel.re +++ b/src/haz3lweb/app/explainthis/ExplainThisModel.re @@ -204,3 +204,15 @@ let get_form_and_options = (group: group, model: t): (form, list((form_id, Segment.t))) => { (get_selected_option(group, model), get_options(group)); }; + +// To prevent OCaml thinking t is a recursive type lower down +[@deriving (show({with_path: false}), yojson, sexp)] +type explainthismodel = t; + +module Store = + Store.F({ + [@deriving (show({with_path: false}), yojson, sexp)] + type t = explainthismodel; + let default = () => init; + let key = Store.ExplainThis; + }); diff --git a/src/haz3lweb/explainthis/data/AppExp.re b/src/haz3lweb/app/explainthis/data/AppExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/AppExp.re rename to src/haz3lweb/app/explainthis/data/AppExp.re diff --git a/src/haz3lweb/explainthis/data/AppPat.re b/src/haz3lweb/app/explainthis/data/AppPat.re similarity index 100% rename from src/haz3lweb/explainthis/data/AppPat.re rename to src/haz3lweb/app/explainthis/data/AppPat.re diff --git a/src/haz3lweb/explainthis/data/ArrowTyp.re b/src/haz3lweb/app/explainthis/data/ArrowTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/ArrowTyp.re rename to src/haz3lweb/app/explainthis/data/ArrowTyp.re diff --git a/src/haz3lweb/explainthis/data/CaseExp.re b/src/haz3lweb/app/explainthis/data/CaseExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/CaseExp.re rename to src/haz3lweb/app/explainthis/data/CaseExp.re diff --git a/src/haz3lweb/explainthis/data/FilterExp.re b/src/haz3lweb/app/explainthis/data/FilterExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/FilterExp.re rename to src/haz3lweb/app/explainthis/data/FilterExp.re diff --git a/src/haz3lweb/explainthis/data/FixFExp.re b/src/haz3lweb/app/explainthis/data/FixFExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/FixFExp.re rename to src/haz3lweb/app/explainthis/data/FixFExp.re diff --git a/src/haz3lweb/explainthis/data/ForallTyp.re b/src/haz3lweb/app/explainthis/data/ForallTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/ForallTyp.re rename to src/haz3lweb/app/explainthis/data/ForallTyp.re diff --git a/src/haz3lweb/explainthis/data/FunctionExp.re b/src/haz3lweb/app/explainthis/data/FunctionExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/FunctionExp.re rename to src/haz3lweb/app/explainthis/data/FunctionExp.re diff --git a/src/haz3lweb/explainthis/data/HoleExp.re b/src/haz3lweb/app/explainthis/data/HoleExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/HoleExp.re rename to src/haz3lweb/app/explainthis/data/HoleExp.re diff --git a/src/haz3lweb/explainthis/data/HolePat.re b/src/haz3lweb/app/explainthis/data/HolePat.re similarity index 100% rename from src/haz3lweb/explainthis/data/HolePat.re rename to src/haz3lweb/app/explainthis/data/HolePat.re diff --git a/src/haz3lweb/explainthis/data/HoleTPat.re b/src/haz3lweb/app/explainthis/data/HoleTPat.re similarity index 100% rename from src/haz3lweb/explainthis/data/HoleTPat.re rename to src/haz3lweb/app/explainthis/data/HoleTPat.re diff --git a/src/haz3lweb/explainthis/data/HoleTemplate.re b/src/haz3lweb/app/explainthis/data/HoleTemplate.re similarity index 100% rename from src/haz3lweb/explainthis/data/HoleTemplate.re rename to src/haz3lweb/app/explainthis/data/HoleTemplate.re diff --git a/src/haz3lweb/explainthis/data/HoleTyp.re b/src/haz3lweb/app/explainthis/data/HoleTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/HoleTyp.re rename to src/haz3lweb/app/explainthis/data/HoleTyp.re diff --git a/src/haz3lweb/explainthis/data/IfExp.re b/src/haz3lweb/app/explainthis/data/IfExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/IfExp.re rename to src/haz3lweb/app/explainthis/data/IfExp.re diff --git a/src/haz3lweb/explainthis/data/LetExp.re b/src/haz3lweb/app/explainthis/data/LetExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/LetExp.re rename to src/haz3lweb/app/explainthis/data/LetExp.re diff --git a/src/haz3lweb/explainthis/data/ListExp.re b/src/haz3lweb/app/explainthis/data/ListExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/ListExp.re rename to src/haz3lweb/app/explainthis/data/ListExp.re diff --git a/src/haz3lweb/explainthis/data/ListPat.re b/src/haz3lweb/app/explainthis/data/ListPat.re similarity index 100% rename from src/haz3lweb/explainthis/data/ListPat.re rename to src/haz3lweb/app/explainthis/data/ListPat.re diff --git a/src/haz3lweb/explainthis/data/ListTyp.re b/src/haz3lweb/app/explainthis/data/ListTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/ListTyp.re rename to src/haz3lweb/app/explainthis/data/ListTyp.re diff --git a/src/haz3lweb/explainthis/data/OpExp.re b/src/haz3lweb/app/explainthis/data/OpExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/OpExp.re rename to src/haz3lweb/app/explainthis/data/OpExp.re diff --git a/src/haz3lweb/explainthis/data/PipelineExp.re b/src/haz3lweb/app/explainthis/data/PipelineExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/PipelineExp.re rename to src/haz3lweb/app/explainthis/data/PipelineExp.re diff --git a/src/haz3lweb/explainthis/data/RecTyp.re b/src/haz3lweb/app/explainthis/data/RecTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/RecTyp.re rename to src/haz3lweb/app/explainthis/data/RecTyp.re diff --git a/src/haz3lweb/explainthis/data/SeqExp.re b/src/haz3lweb/app/explainthis/data/SeqExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/SeqExp.re rename to src/haz3lweb/app/explainthis/data/SeqExp.re diff --git a/src/haz3lweb/explainthis/data/SumTyp.re b/src/haz3lweb/app/explainthis/data/SumTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/SumTyp.re rename to src/haz3lweb/app/explainthis/data/SumTyp.re diff --git a/src/haz3lweb/explainthis/data/TerminalExp.re b/src/haz3lweb/app/explainthis/data/TerminalExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TerminalExp.re rename to src/haz3lweb/app/explainthis/data/TerminalExp.re diff --git a/src/haz3lweb/explainthis/data/TerminalPat.re b/src/haz3lweb/app/explainthis/data/TerminalPat.re similarity index 100% rename from src/haz3lweb/explainthis/data/TerminalPat.re rename to src/haz3lweb/app/explainthis/data/TerminalPat.re diff --git a/src/haz3lweb/explainthis/data/TerminalTyp.re b/src/haz3lweb/app/explainthis/data/TerminalTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TerminalTyp.re rename to src/haz3lweb/app/explainthis/data/TerminalTyp.re diff --git a/src/haz3lweb/explainthis/data/TestExp.re b/src/haz3lweb/app/explainthis/data/TestExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TestExp.re rename to src/haz3lweb/app/explainthis/data/TestExp.re diff --git a/src/haz3lweb/explainthis/data/TupleExp.re b/src/haz3lweb/app/explainthis/data/TupleExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TupleExp.re rename to src/haz3lweb/app/explainthis/data/TupleExp.re diff --git a/src/haz3lweb/explainthis/data/TuplePat.re b/src/haz3lweb/app/explainthis/data/TuplePat.re similarity index 100% rename from src/haz3lweb/explainthis/data/TuplePat.re rename to src/haz3lweb/app/explainthis/data/TuplePat.re diff --git a/src/haz3lweb/explainthis/data/TupleTyp.re b/src/haz3lweb/app/explainthis/data/TupleTyp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TupleTyp.re rename to src/haz3lweb/app/explainthis/data/TupleTyp.re diff --git a/src/haz3lweb/explainthis/data/TyAliasExp.re b/src/haz3lweb/app/explainthis/data/TyAliasExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TyAliasExp.re rename to src/haz3lweb/app/explainthis/data/TyAliasExp.re diff --git a/src/haz3lweb/explainthis/data/TypAnnPat.re b/src/haz3lweb/app/explainthis/data/TypAnnPat.re similarity index 100% rename from src/haz3lweb/explainthis/data/TypAnnPat.re rename to src/haz3lweb/app/explainthis/data/TypAnnPat.re diff --git a/src/haz3lweb/explainthis/data/TypAppExp.re b/src/haz3lweb/app/explainthis/data/TypAppExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TypAppExp.re rename to src/haz3lweb/app/explainthis/data/TypAppExp.re diff --git a/src/haz3lweb/explainthis/data/TypFunctionExp.re b/src/haz3lweb/app/explainthis/data/TypFunctionExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/TypFunctionExp.re rename to src/haz3lweb/app/explainthis/data/TypFunctionExp.re diff --git a/src/haz3lweb/explainthis/data/UndefinedExp.re b/src/haz3lweb/app/explainthis/data/UndefinedExp.re similarity index 100% rename from src/haz3lweb/explainthis/data/UndefinedExp.re rename to src/haz3lweb/app/explainthis/data/UndefinedExp.re diff --git a/src/haz3lweb/explainthis/data/VarTPat.re b/src/haz3lweb/app/explainthis/data/VarTPat.re similarity index 100% rename from src/haz3lweb/explainthis/data/VarTPat.re rename to src/haz3lweb/app/explainthis/data/VarTPat.re diff --git a/src/haz3lweb/app/globals/Globals.re b/src/haz3lweb/app/globals/Globals.re new file mode 100644 index 0000000000..a1608dad4c --- /dev/null +++ b/src/haz3lweb/app/globals/Globals.re @@ -0,0 +1,93 @@ +open Util; + +/* This single data structure collects together all the app-wide values + that might be of interest to view functions. Most view functions then + take ~globals as an argument.*/ + +module Action = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | SetMousedown(bool) + | SetShowBackpackTargets(bool) + | SetFontMetrics(FontMetrics.t) + | Set(Settings.Update.t) + | JumpToTile(Haz3lcore.Id.t) // Perform(Select(Term(Id(id, Left)))) + | InitImportAll([@opaque] Js_of_ocaml.Js.t(Js_of_ocaml.File.file)) + | FinishImportAll(option(string)) + | ExportPersistentData + | ActiveEditor(Haz3lcore.Action.t) + | Undo // These two currently happen at the editor level, and are just + | Redo; // global actions so they can be accessed by the command palette +}; + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + // Persistent: + settings: Settings.t, + // State: + font_metrics: FontMetrics.t, + show_backpack_targets: bool, + mousedown: bool, + // Calculated: + color_highlights: option(ColorSteps.colorMap), + // Other: + inject_global: Action.t => Ui_effect.t(unit), + /* inject_global is not really part of the model, but added here for + convenience to avoid having to pass it around everywhere. Can only + be used in view functions. */ + get_log_and: (string => unit) => unit, + export_all: + ( + ~settings: Haz3lcore.CoreSettings.t, + ~instructor_mode: bool, + ~log: string + ) => + Yojson.Safe.t, + export_persistent: unit => unit, + }; + + let load = () => { + let settings = Settings.Store.load(); + { + font_metrics: FontMetrics.init, + show_backpack_targets: false, + mousedown: false, + settings, + color_highlights: None, + inject_global: _ => + failwith( + "Cannot use inject_global outside of the main view function!", + ), + get_log_and: _ => + failwith( + "Cannot use get_log_and outside of the main view or update functions!", + ), + export_all: (~settings as _, ~instructor_mode as _, ~log as _) => + failwith( + "Cannot use export_all outside of the main view or update functions!", + ), + export_persistent: () => + failwith( + "Cannot use export_persistent outside of the main view function!", + ), + }; + }; + + let save = model => { + Settings.Store.save(model.settings); + }; +}; + +module Update = { + include Action; + + // Update is handled by the top-level update function + + let calculate = (color_highlights, model: Model.t): Model.t => { + ...model, + color_highlights, + }; +}; + +type t = Model.t; diff --git a/src/haz3lweb/FailedInput.re b/src/haz3lweb/app/input/FailedInput.re similarity index 100% rename from src/haz3lweb/FailedInput.re rename to src/haz3lweb/app/input/FailedInput.re diff --git a/src/haz3lweb/app/input/Shortcut.re b/src/haz3lweb/app/input/Shortcut.re new file mode 100644 index 0000000000..5f664d7361 --- /dev/null +++ b/src/haz3lweb/app/input/Shortcut.re @@ -0,0 +1,260 @@ +open Js_of_ocaml; + +type t = { + update_action: option(Page.Update.t), + hotkey: option(string), + label: string, + mdIcon: option(string), + section: option(string), +}; + +let mk_shortcut = (~hotkey=?, ~mdIcon=?, ~section=?, label, update_action): t => { + {update_action: Some(update_action), hotkey, label, mdIcon, section}; +}; + +let instructor_shortcuts: list(t) = [ + mk_shortcut( + ~mdIcon="download", + ~section="Export", + "Export All Persistent Data", + Globals(ExportPersistentData), + ), + mk_shortcut( + ~mdIcon="download", + ~section="Export", + "Export Exercise Module", + Editors(Exercises(ExportModule)) // TODO Would we rather skip contextual stuff for now or include it and have it fail + ), + mk_shortcut( + ~mdIcon="download", + ~section="Export", + "Export Transitionary Exercise Module", + Editors(Exercises(ExportTransitionary)) // TODO Would we rather skip contextual stuff for now or include it and have it fail + ), + mk_shortcut( + ~mdIcon="download", + ~section="Export", + "Export Grading Exercise Module", + Editors(Exercises(ExportGrading)) // TODO Would we rather skip contextual stuff for now or include it and have it fail + ), +]; + +// List of shortcuts configured to show up in the command palette and have hotkey support +let shortcuts = (sys: Util.Key.sys): list(t) => + [ + mk_shortcut( + ~mdIcon="undo", + ~hotkey=Keyboard.meta(sys) ++ "+z", + "Undo", + Globals(Undo), + ), + mk_shortcut( + ~hotkey=Keyboard.meta(sys) ++ "+shift+z", + ~mdIcon="redo", + "Redo", + Globals(Redo), + ), + mk_shortcut( + ~hotkey="F12", + ~mdIcon="arrow_forward", + ~section="Navigation", + "Go to Definition", + Globals(ActiveEditor(Jump(BindingSiteOfIndicatedVar))), + ), + mk_shortcut( + ~hotkey="shift+tab", + ~mdIcon="swipe_left_alt", + ~section="Navigation", + "Go to Previous Hole", + Globals(ActiveEditor(Move(Goal(Piece(Grout, Left))))), + ), + mk_shortcut( + ~mdIcon="swipe_right_alt", + ~section="Navigation", + "Go To Next Hole", + Globals(ActiveEditor(Move(Goal(Piece(Grout, Right))))), + // Tab is overloaded so not setting it here + ), + mk_shortcut( + ~hotkey=Keyboard.meta(sys) ++ "+d", + ~mdIcon="select_all", + ~section="Selection", + "Select current term", + Globals(ActiveEditor(Select(Term(Current)))), + ), + mk_shortcut( + ~hotkey=Keyboard.meta(sys) ++ "+p", + ~mdIcon="backpack", + "Pick up selected term", + Globals(ActiveEditor(Pick_up)), + ), + mk_shortcut( + ~mdIcon="select_all", + ~hotkey=Keyboard.meta(sys) ++ "+a", + ~section="Selection", + "Select All", + Globals(ActiveEditor(Select(All))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Statics", + Globals(Set(Statics)), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Completion", + Globals(Set(Assist)), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Whitespace", + Globals(Set(SecondaryIcons)), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Print Benchmarks", + Globals(Set(Benchmark)), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Toggle Dynamics", + Globals(Set(Dynamics)), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Elaboration", + Globals(Set(Elaborate)), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Function Bodies", + Globals(Set(Evaluation(ShowFnBodies))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Case Clauses", + Globals(Set(Evaluation(ShowCaseClauses))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show fixpoints", + Globals(Set(Evaluation(ShowFixpoints))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Casts", + Globals(Set(Evaluation(ShowCasts))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Lookup Steps", + Globals(Set(Evaluation(ShowLookups))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Stepper Filters", + Globals(Set(Evaluation(ShowFilters))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Hidden Steps", + Globals(Set(Evaluation(ShowHiddenSteps))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Docs Sidebar", + Globals(Set(ExplainThis(ToggleShow))), + ), + mk_shortcut( + ~section="Settings", + ~mdIcon="tune", + "Toggle Show Docs Feedback", + Globals(Set(ExplainThis(ToggleShowFeedback))), + ), + mk_shortcut( + ~hotkey=Keyboard.meta(sys) ++ "+/", + ~mdIcon="assistant", + "TyDi Assistant", + Globals(ActiveEditor(Buffer(Set(TyDi)))) // I haven't figured out how to trigger this in the editor + ), + mk_shortcut( + ~mdIcon="download", + ~section="Export", + "Export Scratch Slide", + Editors(Scratch(Export)), + ), + mk_shortcut( + ~mdIcon="download", + ~section="Export", + "Export Submission", + Editors(Exercises(ExportSubmission)) // TODO Would we rather skip contextual stuff for now or include it and have it fail + ), + mk_shortcut( + // ctrl+k conflicts with the command palette + ~section="Diagnostics", + ~mdIcon="refresh", + "Reparse Current Editor", + Globals(ActiveEditor(Reparse)), + ), + mk_shortcut( + ~mdIcon="timer", + ~section="Diagnostics", + ~hotkey="F7", + "Run Benchmark", + Benchmark(Start), + ), + ] + @ (if (ExerciseSettings.show_instructor) {instructor_shortcuts} else {[]}); + +let from_shortcut = + (schedule_action: Page.Update.t => unit, shortcut: t) + : { + . + "handler": Js.readonly_prop(unit => unit), + "id": Js.readonly_prop(string), + "mdIcon": Js.readonly_prop(Js.optdef(string)), + "hotkey": Js.readonly_prop(Js.optdef(string)), + "title": Js.readonly_prop(string), + "section": Js.readonly_prop(Js.optdef(string)), + } => { + [%js + { + val id = shortcut.label; + val title = shortcut.label; + val mdIcon = Js.Optdef.option(shortcut.mdIcon); + val hotkey = Js.Optdef.option(shortcut.hotkey); + val section = Js.Optdef.option(shortcut.section); + val handler = + () => { + let foo = shortcut.update_action; + switch (foo) { + | Some(update) => schedule_action(update) + | None => + print_endline("Could not find action for " ++ shortcut.label) + }; + } + }]; +}; + +let options = (schedule_action: Page.Update.t => unit) => { + Array.of_list( + List.map( + from_shortcut(schedule_action), + shortcuts(Util.Os.is_mac^ ? Util.Key.Mac : PC), + ), + ); +}; diff --git a/src/haz3lweb/view/CursorInspector.re b/src/haz3lweb/app/inspector/CursorInspector.re similarity index 51% rename from src/haz3lweb/view/CursorInspector.re rename to src/haz3lweb/app/inspector/CursorInspector.re index 879b355999..febb507ada 100644 --- a/src/haz3lweb/view/CursorInspector.re +++ b/src/haz3lweb/app/inspector/CursorInspector.re @@ -8,20 +8,29 @@ let errc = "error"; let okc = "ok"; let div_err = div(~attrs=[clss(["status", errc])]); let div_ok = div(~attrs=[clss(["status", okc])]); +let code_box_container = x => + div(~attrs=[clss(["code-box-container"])], [x]); let code_err = (code: string): Node.t => div(~attrs=[clss(["code"])], [text(code)]); -let explain_this_toggle = (~inject, ~show_explain_this: bool): Node.t => { +let explain_this_toggle = (~globals: Globals.t): Node.t => { let tooltip = "Toggle language documentation"; let toggle_explain_this = _ => Virtual_dom.Vdom.Effect.Many([ - inject(Update.Set(ExplainThis(ToggleShow))), + globals.inject_global(Set(ExplainThis(ToggleShow))), Virtual_dom.Vdom.Effect.Stop_propagation, ]); div( ~attrs=[clss(["explain-this-button"])], - [Widgets.toggle(~tooltip, "?", show_explain_this, toggle_explain_this)], + [ + Widgets.toggle( + ~tooltip, + "?", + globals.settings.explainThis.show, + toggle_explain_this, + ), + ], ); }; @@ -31,28 +40,27 @@ let cls_view = (ci: Info.t): Node.t => [text(ci |> Info.cls_of |> Cls.show)], ); -let ctx_toggle = (~inject, context_inspector: bool): Node.t => +let ctx_toggle = (~globals: Globals.t): Node.t => div( ~attrs=[ - Attr.on_click(_ => inject(Update.Set(ContextInspector))), - clss(["gamma"] @ (context_inspector ? ["visible"] : [])), + Attr.on_click(_ => globals.inject_global(Set(ContextInspector))), + clss( + ["gamma"] @ (globals.settings.context_inspector ? ["visible"] : []), + ), ], [text("Γ")], ); -let term_view = (~inject, ~settings: Settings.t, ci) => { +let term_view = (~globals: Globals.t, ci) => { let sort = ci |> Info.sort_of |> Sort.show; div( ~attrs=[ clss(["ci-header", sort] @ (Info.is_error(ci) ? [errc] : [okc])), ], [ - ctx_toggle(~inject, settings.context_inspector), + ctx_toggle(~globals), div(~attrs=[clss(["term-tag"])], [text(sort)]), - explain_this_toggle( - ~inject, - ~show_explain_this=settings.explainThis.show, - ), + explain_this_toggle(~globals), cls_view(ci), ], ); @@ -66,7 +74,21 @@ let elements_noun: Cls.t => string = | Exp(ListConcat) => "Operands" | _ => failwith("elements_noun: Cls doesn't have elements"); -let common_err_view = (cls: Cls.t, err: Info.error_common) => +let common_err_view = (~globals, cls: Cls.t, err: Info.error_common) => { + let view_type = x => + x + |> CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ~info_map=Id.Map.empty, + ) + |> code_box_container; switch (err) { | NoType(BadToken(token)) => switch (Form.bad_token_cls(token)) { @@ -75,29 +97,42 @@ let common_err_view = (cls: Cls.t, err: Info.error_common) => } | NoType(BadTrivAp(ty)) => [ text("Function argument type"), - Type.view(ty), + view_type(ty), text("inconsistent with"), - Type.view(Prod([]) |> Typ.fresh), + view_type(Prod([]) |> Typ.fresh), ] | NoType(FreeConstructor(name)) => [code_err(name), text("not found")] | Inconsistent(WithArrow(typ)) => [ text(":"), - Type.view(typ), + view_type(typ) |> code_box_container, text("inconsistent with arrow type"), ] | Inconsistent(Expectation({ana, syn})) => [ text(":"), - Type.view(syn), + view_type(syn) |> code_box_container, text("inconsistent with expected type"), - Type.view(ana), + view_type(ana) |> code_box_container, ] | Inconsistent(Internal(tys)) => [ text(elements_noun(cls) ++ " have inconsistent types:"), - ...ListUtil.join(text(","), List.map(Type.view, tys)), + ...ListUtil.join(text(","), List.map(view_type, tys)), ] }; +}; -let common_ok_view = (cls: Cls.t, ok: Info.ok_pat) => { +let common_ok_view = (~globals, cls: Cls.t, ok: Info.ok_pat) => { + let view_type = + CodeViewable.view_typ( + ~globals, + ~info_map=Id.Map.empty, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ); switch (cls, ok) { | (Exp(MultiHole) | Pat(MultiHole), _) => [ text("Expecting operator or delimiter"), @@ -106,61 +141,86 @@ let common_ok_view = (cls: Cls.t, ok: Info.ok_pat) => { | (Pat(EmptyHole), Syn(_)) => [text("Fillable by any pattern")] | (Exp(EmptyHole), Ana(Consistent({ana, _}))) => [ text("Fillable by any expression of type"), - Type.view(ana), + view_type(ana), ] | (Pat(EmptyHole), Ana(Consistent({ana, _}))) => [ text("Fillable by any pattern of type"), - Type.view(ana), + view_type(ana), ] - | (_, Syn(syn)) => [text(":"), Type.view(syn)] + | (_, Syn(syn)) => [text(":"), view_type(syn)] | (Pat(Var) | Pat(Wild), Ana(Consistent({ana, _}))) => [ text(":"), - Type.view(ana), + view_type(ana), ] | (_, Ana(Consistent({ana, syn, _}))) when ana == syn => [ text(":"), - Type.view(syn), + view_type(syn), text("equals expected type"), ] | (_, Ana(Consistent({ana, syn, _}))) => [ text(":"), - Type.view(syn), + view_type(syn), text("consistent with expected type"), - Type.view(ana), + view_type(ana), ] | (_, Ana(InternallyInconsistent({ana, nojoin: tys}))) => [ text(elements_noun(cls) ++ " have inconsistent types:"), - ...ListUtil.join(text(","), List.map(Type.view, tys)), + ...ListUtil.join(text(","), List.map(view_type, tys)), ] - @ [text("but consistent with expected"), Type.view(ana)] + @ [text("but consistent with expected"), view_type(ana)] }; }; -let typ_ok_view = (cls: Cls.t, ok: Info.ok_typ) => +let typ_ok_view = (~globals, cls: Cls.t, ok: Info.ok_typ) => { + let view_type = + CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ~info_map=Id.Map.empty, + ); switch (ok) { | Type(_) when cls == Typ(EmptyHole) => [text("Fillable by any type")] - | Type(ty) => [Type.view(ty), text("is a type")] + | Type(ty) => [view_type(ty), text("is a type")] | TypeAlias(name, ty_lookup) => [ - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh), text("is an alias for"), - Type.view(ty_lookup), + view_type(ty_lookup), ] | Variant(name, sum_ty) => [ - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh), text("is a sum type constuctor of type"), - Type.view(sum_ty), + view_type(sum_ty), ] | VariantIncomplete(sum_ty) => [ text("An incomplete sum type constuctor of type"), - Type.view(sum_ty), + view_type(sum_ty), ] }; +}; -let typ_err_view = (ok: Info.error_typ) => +let typ_err_view = (~globals, ok: Info.error_typ) => { + let view_type = + CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ~info_map=Id.Map.empty, + ); switch (ok) { | FreeTypeVariable(name) => [ - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh) |> code_box_container, text("not found"), ] | BadToken(token) => [ @@ -171,12 +231,25 @@ let typ_err_view = (ok: Info.error_typ) => | WantConstructorFoundType(_) => [text("Expected a constructor")] | WantTypeFoundAp => [text("Must be part of a sum type")] | DuplicateConstructor(name) => [ - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh) |> code_box_container, text("already used in this sum"), ] }; +}; -let rec exp_view = (cls: Cls.t, status: Info.status_exp) => +let rec exp_view = (~globals, cls: Cls.t, status: Info.status_exp) => { + let view_type = + CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ~info_map=Id.Map.empty, + ); switch (status) { | InHole(FreeVariable(name)) => div_err([code_err(name), text("not found")]) @@ -187,7 +260,7 @@ let rec exp_view = (cls: Cls.t, status: Info.status_exp) => | Some(err) => let cls_str = String.uncapitalize_ascii(cls_str); div_err([ - exp_view(cls, InHole(Common(err))), + exp_view(~globals, cls, InHole(Common(err))) |> code_box_container, text("; " ++ cls_str ++ " is inexhaustive"), ]); }; @@ -207,82 +280,100 @@ let rec exp_view = (cls: Cls.t, status: Info.status_exp) => ++ " arguments", ), ]) - | InHole(Common(error)) => div_err(common_err_view(cls, error)) + | InHole(Common(error)) => div_err(common_err_view(~globals, cls, error)) | NotInHole(AnaDeferralConsistent(ana)) => - div_ok([text("Expecting type"), Type.view(ana)]) - | NotInHole(Common(ok)) => div_ok(common_ok_view(cls, ok)) + div_ok([text("Expecting type"), view_type(ana)]) + | NotInHole(Common(ok)) => div_ok(common_ok_view(~globals, cls, ok)) }; +}; -let rec pat_view = (cls: Cls.t, status: Info.status_pat) => +let rec pat_view = (~globals, cls: Cls.t, status: Info.status_pat) => switch (status) { | InHole(ExpectedConstructor) => div_err([text("Expected a constructor")]) | InHole(Redundant(additional_err)) => switch (additional_err) { | None => div_err([text("Pattern is redundant")]) | Some(err) => - div_err([pat_view(cls, InHole(err)), text("; pattern is redundant")]) + div_err([ + pat_view(~globals, cls, InHole(err)) |> code_box_container, + text("; pattern is redundant"), + ]) } - | InHole(Common(error)) => div_err(common_err_view(cls, error)) - | NotInHole(ok) => div_ok(common_ok_view(cls, ok)) + | InHole(Common(error)) => div_err(common_err_view(~globals, cls, error)) + | NotInHole(ok) => div_ok(common_ok_view(~globals, cls, ok)) }; -let typ_view = (cls: Cls.t, status: Info.status_typ) => +let typ_view = (~globals, cls: Cls.t, status: Info.status_typ) => switch (status) { - | NotInHole(ok) => div_ok(typ_ok_view(cls, ok)) - | InHole(err) => div_err(typ_err_view(err)) + | NotInHole(ok) => div_ok(typ_ok_view(~globals, cls, ok)) + | InHole(err) => div_err(typ_err_view(~globals, err)) }; -let tpat_view = (_: Cls.t, status: Info.status_tpat) => +let tpat_view = (~globals, _: Cls.t, status: Info.status_tpat) => { + let view_type = + CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ~info_map=Id.Map.empty, + ); switch (status) { | NotInHole(Empty) => div_ok([text("Fillable with a new alias")]) - | NotInHole(Var(name)) => div_ok([Type.alias_view(name)]) + | NotInHole(Var(name)) => div_ok([ContextInspector.alias_view(name)]) | InHole(NotAVar(NotCapitalized)) => div_err([text("Must begin with a capital letter")]) | InHole(NotAVar(_)) => div_err([text("Expected an alias")]) | InHole(ShadowsType(name, BaseTyp)) => div_err([ text("Can't shadow base type"), - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh) |> code_box_container, ]) | InHole(ShadowsType(name, TyAlias)) => div_err([ text("Can't shadow existing alias"), - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh) |> code_box_container, ]) | InHole(ShadowsType(name, TyVar)) => div_err([ text("Can't shadow existing type variable"), - Type.view(Var(name) |> Typ.fresh), + view_type(Var(name) |> Typ.fresh) |> code_box_container, ]) }; +}; let secondary_view = (cls: Cls.t) => div_ok([text(cls |> Cls.show)]); -let view_of_info = (~inject, ~settings, ci): list(Node.t) => { - let wrapper = status_view => [ - term_view(~inject, ~settings, ci), - status_view, - ]; +let view_of_info = (~globals, ci): list(Node.t) => { + let wrapper = status_view => [term_view(~globals, ci), status_view]; switch (ci) { | Secondary(_) => wrapper(div([])) - | InfoExp({cls, status, _}) => wrapper(exp_view(cls, status)) - | InfoPat({cls, status, _}) => wrapper(pat_view(cls, status)) - | InfoTyp({cls, status, _}) => wrapper(typ_view(cls, status)) - | InfoTPat({cls, status, _}) => wrapper(tpat_view(cls, status)) + | InfoExp({cls, status, _}) => wrapper(exp_view(~globals, cls, status)) + | InfoPat({cls, status, _}) => wrapper(pat_view(~globals, cls, status)) + | InfoTyp({cls, status, _}) => wrapper(typ_view(~globals, cls, status)) + | InfoTPat({cls, status, _}) => wrapper(tpat_view(~globals, cls, status)) }; }; -let inspector_view = (~inject, ~settings, ci): Node.t => +let inspector_view = (~globals, ci): Node.t => div( ~attrs=[ Attr.id("cursor-inspector"), clss([Info.is_error(ci) ? errc : okc]), ], - view_of_info(~inject, ~settings, ci), + view_of_info(~globals, ci), ); let view = - (~inject, ~settings: Settings.t, editor, cursor_info: option(Info.t)) => { + ( + ~globals: Globals.t, + ~inject: Editors.Update.t => 'a, + cursor: Cursor.cursor(Editors.Update.t), + ) => { let bar_view = div(~attrs=[Attr.id("bottom-bar")]); let err_view = err => bar_view([ @@ -291,16 +382,19 @@ let view = [div(~attrs=[clss(["icon"])], [Icons.magnify]), text(err)], ), ]); - switch (cursor_info) { - | _ when !settings.core.statics => div_empty + switch (cursor.info) { + | _ when !globals.settings.core.statics => div_empty | None => err_view("Whitespace or Comment") | Some(ci) => bar_view([ - inspector_view(~inject, ~settings, ci), - ProjectorView.Panel.view( - ~inject=a => inject(PerformAction(Project(a))), - editor, - ci, + inspector_view(~globals, ci), + ProjectorPanel.view( + ~inject= + a => + cursor.editor_action(Project(a)) + |> Option.map(inject) + |> Option.value(~default=Ui_effect.Ignore), + cursor, ), ]) }; diff --git a/src/haz3lweb/app/inspector/ProjectorPanel.re b/src/haz3lweb/app/inspector/ProjectorPanel.re new file mode 100644 index 0000000000..6a19da402c --- /dev/null +++ b/src/haz3lweb/app/inspector/ProjectorPanel.re @@ -0,0 +1,137 @@ +open Haz3lcore; +open Virtual_dom.Vdom; +open Node; +open Projector; +open Util.OptUtil.Syntax; +open Util.Web; + +/* The projector selection panel on the right of the bottom bar */ +let option_view = (name, n) => + option( + ~attrs=n == name ? [Attr.create("selected", "selected")] : [], + [text(n)], + ); + +/* Decide which projectors are applicable based on the cursor info. + * This is slightly inside-out as elsewhere it depends on the underlying + * syntax, which is not easily available here */ +let applicable_projectors: option(Info.t) => list(Base.kind) = + fun + | None => [] + | Some(ci) => + ( + switch (Info.cls_of(ci)) { + | Exp(Bool) + | Pat(Bool) => [Base.Checkbox] + | Exp(Int) + | Pat(Int) => [Slider] + | Exp(Float) + | Pat(Float) => [SliderF] + | Exp(String) + | Pat(String) => [TextArea] + | _ => [] + } + ) + @ [Base.Fold] + @ ( + switch (ci) { + | InfoExp(_) + | InfoPat(_) => [(Info: Base.kind)] + | _ => [] + } + ); + +let toggle_projector = (active, id, ci: option(Info.t)): Action.project => + active || applicable_projectors(ci) == [] + ? Remove(id) : SetIndicated(List.hd(applicable_projectors(ci))); + +let toggle_view = + (~inject, ci: option(Info.t), id, active: bool, might_project) => + div( + ~attrs=[ + clss( + ["toggle-switch"] + @ (active ? ["active"] : []) + @ (might_project ? [] : ["inactive"]), + ), + Attr.on_mousedown(_ => + might_project + ? inject(toggle_projector(active, id, ci)) : Effect.Ignore + ), + ], + [ + div( + ~attrs=[clss(["toggle-knob"])], + [ + Node.create( + "img", + ~attrs=[Attr.src("img/noun-fold-1593402.svg")], + [], + ), + ], + ), + ], + ); + +let kind = (editor: option(Editor.t)) => { + let* editor = editor; + let+ (_, p) = Editor.Model.indicated_projector(editor); + p.kind; +}; + +let id = (editor: option(Editor.t)) => { + { + let* editor = editor; + let+ (id, _) = Editor.Model.indicated_projector(editor); + id; + } + |> Option.value(~default=Id.invalid); +}; + +let might_project: Cursor.cursor(Editors.Update.t) => bool = + cursor => + switch (cursor.editor) { + | _ when cursor.editor_read_only => false + | None => false + | Some(editor) => + switch (Indicated.piece''(editor.state.zipper)) { + | None => false + | Some((p, _, _)) => minimum_projection_condition(p) + } + }; + +let currently_selected = editor => + option_view( + switch (kind(editor)) { + | None => "Fold" + | Some(k) => ProjectorView.name(k) + }, + ); + +let view = (~inject, cursor: Cursor.cursor(Editors.Update.t)) => { + let applicable_projectors = applicable_projectors(cursor.info); + let should_show = might_project(cursor) && applicable_projectors != []; + let select_view = + Node.select( + ~attrs=[ + Attr.on_change((_, name) => + inject(Action.SetIndicated(ProjectorView.of_name(name))) + ), + ], + (might_project(cursor) ? applicable_projectors : []) + |> List.map(ProjectorView.name) + |> List.map(currently_selected(cursor.editor)), + ); + let toggle_view = + toggle_view( + ~inject, + cursor.info, + id(cursor.editor), + kind(cursor.editor) != None, + might_project(cursor), + ); + div( + ~attrs=[Attr.id("projectors")], + (should_show ? [select_view] : []) @ [toggle_view], + ); +}; diff --git a/src/haz3lweb/Benchmark.re b/src/haz3lweb/debug/Benchmark.re similarity index 88% rename from src/haz3lweb/Benchmark.re rename to src/haz3lweb/debug/Benchmark.re index 6361b8143e..ad4329f9b7 100644 --- a/src/haz3lweb/Benchmark.re +++ b/src/haz3lweb/debug/Benchmark.re @@ -40,16 +40,16 @@ let non_empty_hole : Int = true in 2 + 2 |}; -let str_to_inserts = (str: string): list(UpdateAction.t) => +let str_to_inserts = (str: string): list(Editors.Update.t) => List.init( String.length(str), i => { let c = String.sub(str, i, 1); - UpdateAction.PerformAction(Insert(c)); + Editors.Update.Scratch(CellAction(MainEditor(Perform(Insert(c))))); }, ); -let actions_1 = str_to_inserts(sample_1) @ [Benchmark(Finish)]; +let actions_1 = str_to_inserts(sample_1); let time = ref(-1.0); diff --git a/src/haz3lweb/DebugConsole.re b/src/haz3lweb/debug/DebugConsole.re similarity index 67% rename from src/haz3lweb/DebugConsole.re rename to src/haz3lweb/debug/DebugConsole.re index a7f6d8ee33..3a93554eb3 100644 --- a/src/haz3lweb/DebugConsole.re +++ b/src/haz3lweb/debug/DebugConsole.re @@ -4,10 +4,12 @@ open Haz3lcore; It was originally directly in Keyboard, but that added a handler dependency on the model, which is technically against architecture */ -let print = ({settings, editors, _}: Model.t, key: string): unit => { - let {state: {zipper, meta, _}, _}: Editor.t = Editors.get_editor(editors); - let term = meta.statics.term; - let map = meta.statics.info_map; +let print = + (~settings: Settings.t, editor: CodeWithStatics.Model.t, key: string) + : unit => { + let {editor: {state: {zipper, _}, _}, statics}: CodeWithStatics.Model.t = editor; + let term = statics.term; + let map = statics.info_map; let print = print_endline; switch (key) { | "F1" => zipper |> Zipper.show |> print @@ -15,10 +17,10 @@ let print = ({settings, editors, _}: Model.t, key: string): unit => { | "F3" => term |> UExp.show |> print | "F4" => map |> Statics.Map.show |> print | "F5" => - let env = Editors.get_env_init(~settings, editors); - Interface.elaborate(~settings=settings.core, map, term) - |> Interface.evaluate(~settings=settings.core, ~env) - |> ProgramResult.show + let env_init = Builtins.env_init; + statics.elaborated + |> Evaluator.evaluate(~settings=settings.core, ~env=env_init) + |> ProgramResult.show(ProgramResult.pp_inner) |> print; | "F6" => let index = Indicated.index(zipper); diff --git a/src/haz3lweb/view/DebugMode.re b/src/haz3lweb/debug/DebugMode.re similarity index 93% rename from src/haz3lweb/view/DebugMode.re rename to src/haz3lweb/debug/DebugMode.re index 39cba26eb8..6963af03bd 100644 --- a/src/haz3lweb/view/DebugMode.re +++ b/src/haz3lweb/debug/DebugMode.re @@ -9,8 +9,8 @@ type action = let perform = (action: action): unit => { switch (action) { | TurnOffDynamics => - let settings = Store.Settings.load(); - Store.Settings.save({ + let settings = Settings.Store.load(); + Settings.Store.save({ ...settings, core: { ...settings.core, diff --git a/src/haz3lweb/dune b/src/haz3lweb/dune index e2792b76b8..616712dd3c 100644 --- a/src/haz3lweb/dune +++ b/src/haz3lweb/dune @@ -11,13 +11,13 @@ (instrumentation (backend bisect_ppx)) (libraries + str bonsai bonsai.web virtual_dom.input_widgets util ppx_yojson_conv.expander haz3lcore - haz3lschool pretty omd) (js_of_ocaml) @@ -34,7 +34,7 @@ (instrumentation (backend bisect_ppx)) (modules - (:standard \ Main) + (:standard \ Main Gradescope) \ Worker WorkerServer) @@ -49,7 +49,6 @@ util ppx_yojson_conv.expander haz3lcore - haz3lschool pretty omd) (js_of_ocaml) diff --git a/src/haz3lweb/exercises/Exercise.re b/src/haz3lweb/exercises/Exercise.re new file mode 100644 index 0000000000..613d0d47be --- /dev/null +++ b/src/haz3lweb/exercises/Exercise.re @@ -0,0 +1,660 @@ +open Util; +open Haz3lcore; +open Web; + +let output_header_grading = _module_name => + "module Exercise = GradePrelude.Exercise\n" ++ "let prompt = ()\n"; + +[@deriving (show({with_path: false}), sexp, yojson)] +type wrong_impl('code) = { + impl: 'code, + hint: string, +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type hidden_tests('code) = { + tests: 'code, + hints: list(string), +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type hint = string; + +[@deriving (show({with_path: false}), sexp, yojson)] +type syntax_test = (hint, SyntaxTest.predicate); + +[@deriving (show({with_path: false}), sexp, yojson)] +type syntax_tests = list(syntax_test); + +[@deriving (show({with_path: false}), sexp, yojson)] +type your_tests('code) = { + tests: 'code, + required: int, + provided: int, +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type point_distribution = { + test_validation: int, + mutation_testing: int, + impl_grading: int, +}; + +let validate_point_distribution = + ({test_validation, mutation_testing, impl_grading}: point_distribution) => + test_validation + mutation_testing + impl_grading == 100 + ? () : failwith("Invalid point distribution in exercise."); + +[@deriving (show({with_path: false}), sexp, yojson)] +type p('code) = { + title: string, + version: int, + module_name: string, + prompt: + [@printer (fmt, _) => Format.pp_print_string(fmt, "prompt")] [@opaque] Node.t, + point_distribution, + prelude: 'code, + correct_impl: 'code, + your_tests: your_tests('code), + your_impl: 'code, + hidden_bugs: list(wrong_impl('code)), + hidden_tests: hidden_tests('code), + syntax_tests, +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type key = (string, int); + +let key_of = p => { + (p.title, p.version); +}; + +let find_key_opt = (key, specs: list(p('code))) => { + specs |> Util.ListUtil.findi_opt(spec => key_of(spec) == key); +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type pos = + | Prelude + | CorrectImpl + | YourTestsValidation + | YourTestsTesting + | YourImpl + | HiddenBugs(int) + | HiddenTests; + +[@deriving (show({with_path: false}), sexp, yojson)] +type spec = p(Zipper.t); + +[@deriving (show({with_path: false}), sexp, yojson)] +type transitionary_spec = p(CodeString.t); + +let map = (p: p('a), f: 'a => 'b, f_hidden: 'a => 'b): p('b) => { + { + title: p.title, + version: p.version, + module_name: p.module_name, + prompt: p.prompt, + point_distribution: p.point_distribution, + prelude: f_hidden(p.prelude), + correct_impl: f_hidden(p.correct_impl), + your_tests: { + tests: f(p.your_tests.tests), + required: p.your_tests.required, + provided: p.your_tests.provided, + }, + your_impl: f(p.your_impl), + hidden_bugs: + p.hidden_bugs + |> List.map(wrong_impl => { + {impl: f_hidden(wrong_impl.impl), hint: wrong_impl.hint} + }), + hidden_tests: { + tests: f_hidden(p.hidden_tests.tests), + hints: p.hidden_tests.hints, + }, + syntax_tests: p.syntax_tests, + }; +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type eds = p(Editor.t); + +[@deriving (show({with_path: false}), sexp, yojson)] +type state = {eds}; + +let key_of_state = eds => key_of(eds); + +[@deriving (show({with_path: false}), sexp, yojson)] +type persistent_state = list((pos, PersistentZipper.t)); + +let main_editor_of_state = (~selection: pos, eds) => + switch (selection) { + | Prelude => eds.prelude + | CorrectImpl => eds.correct_impl + | YourTestsValidation => eds.your_tests.tests + | YourTestsTesting => eds.your_tests.tests + | YourImpl => eds.your_impl + | HiddenBugs(i) => List.nth(eds.hidden_bugs, i).impl + | HiddenTests => eds.hidden_tests.tests + }; + +let put_main_editor = (~selection: pos, eds: p('a), editor: 'a): p('a) => + switch (selection) { + | Prelude => {...eds, prelude: editor} + | CorrectImpl => {...eds, correct_impl: editor} + | YourTestsValidation + | YourTestsTesting => { + ...eds, + your_tests: { + ...eds.your_tests, + tests: editor, + }, + } + | YourImpl => {...eds, your_impl: editor} + | HiddenBugs(n) => { + ...eds, + hidden_bugs: + Util.ListUtil.put_nth( + n, + {...List.nth(eds.hidden_bugs, n), impl: editor}, + eds.hidden_bugs, + ), + } + | HiddenTests => { + ...eds, + hidden_tests: { + ...eds.hidden_tests, + tests: editor, + }, + } + }; + +let editors = eds => + [ + eds.prelude, + eds.correct_impl, + eds.your_tests.tests, + eds.your_tests.tests, + eds.your_impl, + ] + @ List.map(wrong_impl => wrong_impl.impl, eds.hidden_bugs) + @ [eds.hidden_tests.tests]; + +let editor_positions = eds => + [Prelude, CorrectImpl, YourTestsTesting, YourTestsValidation, YourImpl] + @ List.mapi((i, _) => HiddenBugs(i), eds.hidden_bugs) + @ [HiddenTests]; + +let positioned_editors = state => + List.combine(editor_positions(state), editors(state)); + +let idx_of_pos = (pos, p: p('code)) => + switch (pos) { + | Prelude => 0 + | CorrectImpl => 1 + | YourTestsTesting => 2 + | YourTestsValidation => 3 + | YourImpl => 4 + | HiddenBugs(i) => + if (i < List.length(p.hidden_bugs)) { + 5 + i; + } else { + failwith("invalid hidden bug index"); + } + | HiddenTests => 5 + List.length(p.hidden_bugs) + }; + +let pos_of_idx = (p: p('code), idx: int) => + switch (idx) { + | 0 => Prelude + | 1 => CorrectImpl + | 2 => YourTestsTesting + | 3 => YourTestsValidation + | 4 => YourImpl + | _ => + if (idx < 0) { + failwith("negative idx"); + } else if (idx < 5 + List.length(p.hidden_bugs)) { + HiddenBugs(idx - 5); + } else if (idx == 5 + List.length(p.hidden_bugs)) { + HiddenTests; + } else { + failwith("element idx"); + } + }; + +let zipper_of_code = code => { + switch (Printer.zipper_of_string(code)) { + | None => failwith("Transition failed.") + | Some(zipper) => zipper + }; +}; + +let transition: transitionary_spec => spec = + ( + { + title, + version, + module_name, + prompt, + point_distribution, + prelude, + correct_impl, + your_tests, + your_impl, + hidden_bugs, + hidden_tests, + syntax_tests, + }, + ) => { + let prelude = zipper_of_code(prelude); + let correct_impl = zipper_of_code(correct_impl); + let your_tests = { + let tests = zipper_of_code(your_tests.tests); + {tests, required: your_tests.required, provided: your_tests.provided}; + }; + let your_impl = zipper_of_code(your_impl); + let hidden_bugs = + List.fold_left( + (acc, {impl, hint}) => { + let impl = zipper_of_code(impl); + acc @ [{impl, hint}]; + }, + [], + hidden_bugs, + ); + let hidden_tests = { + let {tests, hints} = hidden_tests; + let tests = zipper_of_code(tests); + {tests, hints}; + }; + { + title, + version, + module_name, + prompt, + point_distribution, + prelude, + correct_impl, + your_tests, + your_impl, + hidden_bugs, + hidden_tests, + syntax_tests, + }; + }; + +let eds_of_spec = + ( + { + title, + version, + module_name, + prompt, + point_distribution, + prelude, + correct_impl, + your_tests, + your_impl, + hidden_bugs, + hidden_tests, + syntax_tests, + }, + ~settings as _: CoreSettings.t, + ) => { + let editor_of_serialization = Editor.Model.mk; + let prelude = editor_of_serialization(prelude); + let correct_impl = editor_of_serialization(correct_impl); + let your_tests = { + let tests = editor_of_serialization(your_tests.tests); + {tests, required: your_tests.required, provided: your_tests.provided}; + }; + let your_impl = editor_of_serialization(your_impl); + let hidden_bugs = + hidden_bugs + |> List.map(({impl, hint}) => { + let impl = editor_of_serialization(impl); + {impl, hint}; + }); + let hidden_tests = { + let {tests, hints} = hidden_tests; + let tests = editor_of_serialization(tests); + {tests, hints}; + }; + { + title, + version, + module_name, + prompt, + point_distribution, + prelude, + correct_impl, + your_tests, + your_impl, + hidden_bugs, + hidden_tests, + syntax_tests, + }; +}; + +// +// Old version of above that did string-based parsing, may be useful +// for transitions between zipper data structure versions (TODO) +// + +let visible_in = (pos, ~instructor_mode) => { + switch (pos) { + | Prelude => instructor_mode + | CorrectImpl => instructor_mode + | YourTestsValidation => true + | YourTestsTesting => true + | YourImpl => true + | HiddenBugs(_) => instructor_mode + | HiddenTests => instructor_mode + }; +}; + +// # Stitching + +module TermItem = { + type t = { + term: Exp.t, + editor: Editor.t, + }; +}; + +module StaticsItem = { + type t = CachedStatics.t; +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type stitched('a) = { + test_validation: 'a, // prelude + correct_impl + your_tests + user_impl: 'a, // prelude + your_impl + user_tests: 'a, // prelude + your_impl + your_tests + prelude: 'a, // prelude + instructor: 'a, // prelude + correct_impl + hidden_tests.tests // TODO only needs to run in instructor mode + hidden_bugs: list('a), // prelude + hidden_bugs[i].impl + your_tests, + hidden_tests: 'a, +}; + +let map_stitched = (f: (pos, 'a) => 'b, s: stitched('a)): stitched('b) => { + test_validation: f(YourTestsValidation, s.test_validation), + user_impl: f(YourImpl, s.user_impl), + user_tests: f(YourTestsTesting, s.user_tests), + prelude: f(Prelude, s.prelude), + instructor: f(CorrectImpl, s.instructor), + hidden_bugs: List.mapi((i, p) => f(HiddenBugs(i), p), s.hidden_bugs), + hidden_tests: f(HiddenTests, s.hidden_tests), +}; + +let get_stitched = (pos, s: stitched('a)): 'a => + switch (pos) { + | YourTestsValidation => s.test_validation + | YourImpl => s.user_impl + | YourTestsTesting => s.user_tests + | Prelude => s.prelude + | CorrectImpl => s.instructor + | HiddenBugs(i) => List.nth(s.hidden_bugs, i) + | HiddenTests => s.hidden_tests + }; + +let map2_stitched = + (f: (pos, 'a, 'b) => 'c, s1: stitched('a), s2: stitched('b)) + : stitched('c) => + map_stitched((pos, a) => f(pos, a, get_stitched(pos, s2)), s1); + +let put_stitched = (pos, s: stitched('a), x: 'a): stitched('a) => + switch (pos) { + | YourTestsValidation => {...s, test_validation: x} + | YourImpl => {...s, user_impl: x} + | YourTestsTesting => {...s, user_tests: x} + | Prelude => {...s, prelude: x} + | CorrectImpl => {...s, instructor: x} + | HiddenBugs(i) => { + ...s, + hidden_bugs: Util.ListUtil.put_nth(i, x, s.hidden_bugs), + } + | HiddenTests => {...s, hidden_tests: x} + }; + +let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => { + term: + Filter( + Filter({ + act: FilterAction.(act, One), + pat: { + term: Constructor("$e", Unknown(Internal) |> Typ.temp), + copied: false, + ids: [Id.mk()], + }, + }), + term, + ), + copied: false, + ids: [Id.mk()], +}; + +let wrap = (term, editor: Editor.t): TermItem.t => {term, editor}; + +let term_of = (editor: Editor.t): UExp.t => + MakeTerm.from_zip_for_sem(editor.state.zipper).term; + +let stitch3 = (ed1: Editor.t, ed2: Editor.t, ed3: Editor.t) => + EditorUtil.append_exp( + EditorUtil.append_exp(term_of(ed1), term_of(ed2)), + term_of(ed3), + ); + +let stitch_term = (eds: p('a)): stitched(TermItem.t) => { + let instructor = + stitch3(eds.prelude, eds.correct_impl, eds.hidden_tests.tests); + let user_impl_term = { + let your_impl_term = + eds.your_impl |> term_of |> wrap_filter(FilterAction.Step); + let prelude_term = + eds.prelude |> term_of |> wrap_filter(FilterAction.Eval); + EditorUtil.append_exp(prelude_term, your_impl_term); + }; + let test_validation_term = + stitch3(eds.prelude, eds.correct_impl, eds.your_tests.tests); + let user_tests_term = + EditorUtil.append_exp(user_impl_term, term_of(eds.your_tests.tests)); + let hidden_tests_term = + EditorUtil.append_exp(user_impl_term, term_of(eds.hidden_tests.tests)); + { + test_validation: wrap(test_validation_term, eds.your_tests.tests), + user_impl: wrap(user_impl_term, eds.your_impl), + user_tests: wrap(user_tests_term, eds.your_tests.tests), + // instructor works here as long as you don't shadow anything in the prelude + prelude: wrap(instructor, eds.prelude), + instructor: wrap(instructor, eds.correct_impl), + hidden_bugs: + List.map( + (t): TermItem.t => + wrap(stitch3(eds.prelude, t.impl, eds.your_tests.tests), t.impl), + eds.hidden_bugs, + ), + hidden_tests: wrap(hidden_tests_term, eds.hidden_tests.tests), + }; +}; +let stitch_term = Core.Memo.general(stitch_term); + +let prelude_key = "prelude"; +let test_validation_key = "test_validation"; +let user_impl_key = "user_impl"; +let user_tests_key = "user_tests"; +let instructor_key = "instructor"; +let hidden_bugs_key = n => "hidden_bugs_" ++ string_of_int(n); +let hidden_tests_key = "hidden_tests"; + +let key_for_statics = (pos: pos): string => + switch (pos) { + | Prelude => prelude_key + | CorrectImpl => instructor_key + | YourTestsValidation => test_validation_key + | YourTestsTesting => user_tests_key + | YourImpl => user_impl_key + | HiddenBugs(idx) => hidden_bugs_key(idx) + | HiddenTests => hidden_tests_key + }; + +let pos_of_key = (key: string): pos => + switch () { + | _ when key == prelude_key => Prelude + | _ when key == test_validation_key => YourTestsValidation + | _ when key == user_impl_key => YourImpl + | _ when key == user_tests_key => YourTestsTesting + | _ when key == instructor_key => CorrectImpl + | _ when String.starts_with(key, ~prefix="hidden_bugs_") => + let n = + String.sub( + key, + String.length("hidden_bugs_"), + String.length(key) - String.length("hidden_bugs_"), + ); + HiddenBugs(int_of_string(n)); + | _ when key == hidden_tests_key => HiddenTests + | _ => failwith("invalid key") + }; + +// // Module Export + +let editor_pp = (fmt, editor: Editor.t) => { + let zipper = editor.state.zipper; + let serialization = Zipper.show(zipper); + // let string_literal = "\"" ++ String.escaped(serialization) ++ "\""; + Format.pp_print_string(fmt, serialization); +}; + +let export_module = (module_name, {eds, _}: state) => { + let prefix = + "let prompt = " + ++ module_name + ++ "_prompt.prompt\n" + ++ "let exercise: Exercise.spec = "; + let record = show_p(editor_pp, eds); + let data = prefix ++ record ++ "\n"; + data; +}; + +let transitionary_editor_pp = (fmt, editor: Editor.t) => { + let zipper = editor.state.zipper; + let code = Printer.to_string_basic(zipper); + Format.pp_print_string(fmt, "\"" ++ String.escaped(code) ++ "\""); +}; + +let export_transitionary_module = (module_name, {eds, _}: state) => { + let prefix = + "let prompt = " + ++ module_name + ++ "_prompt.prompt\n" + ++ "let exercise: Exercise.spec = Exercise.transition("; + let record = show_p(transitionary_editor_pp, eds); + let data = prefix ++ record ++ ")\n"; + data; +}; + +let export_grading_module = (module_name, {eds, _}: state) => { + let header = output_header_grading(module_name); + let prefix = "let exercise: Exercise.spec = "; + let record = show_p(editor_pp, eds); + let data = header ++ prefix ++ record ++ "\n"; + data; +}; + +let blank_spec = + ( + ~title, + ~module_name, + ~point_distribution, + ~required_tests, + ~provided_tests, + ~num_wrong_impls, + ) => { + let prelude = Zipper.next_blank(); + let correct_impl = Zipper.next_blank(); + let your_tests_tests = Zipper.next_blank(); + let your_impl = Zipper.next_blank(); + let hidden_bugs = + List.init( + num_wrong_impls, + i => { + let zipper = Zipper.next_blank(); + {impl: zipper, hint: "TODO: hint " ++ string_of_int(i)}; + }, + ); + let hidden_tests_tests = Zipper.next_blank(); + { + title, + version: 1, + module_name, + prompt: Node.text("TODO: prompt"), + point_distribution, + prelude, + correct_impl, + your_tests: { + tests: your_tests_tests, + required: required_tests, + provided: provided_tests, + }, + your_impl, + hidden_bugs, + hidden_tests: { + tests: hidden_tests_tests, + hints: [], + }, + syntax_tests: [], + }; +}; + +[@deriving (show({with_path: false}), sexp, yojson)] +type persistent_exercise_mode = list((pos, PersistentZipper.t)); + +let unpersist = (~instructor_mode, positioned_zippers, spec: spec): spec => { + let lookup = (pos, default) => + if (visible_in(pos, ~instructor_mode)) { + positioned_zippers + |> List.assoc_opt(pos) + |> Option.map(PersistentZipper.unpersist) + |> Option.value(~default); + } else { + default; + }; + let prelude = lookup(Prelude, spec.prelude); + let correct_impl = lookup(CorrectImpl, spec.correct_impl); + let your_tests_tests = lookup(YourTestsValidation, spec.your_tests.tests); + let your_impl = lookup(YourImpl, spec.your_impl); + let (_, hidden_bugs) = + List.fold_left( + ((i, hidden_bugs: list(wrong_impl('a))), {impl, hint}) => { + let impl = lookup(HiddenBugs(i), impl); + (i + 1, hidden_bugs @ [{impl, hint}]); + }, + (0, []), + spec.hidden_bugs, + ); + let hidden_tests_tests = lookup(HiddenTests, spec.hidden_tests.tests); + { + title: spec.title, + version: spec.version, + module_name: spec.module_name, + prompt: spec.prompt, + point_distribution: spec.point_distribution, + prelude, + correct_impl, + your_tests: { + tests: your_tests_tests, + required: spec.your_tests.required, + provided: spec.your_tests.provided, + }, + your_impl, + hidden_bugs, + hidden_tests: { + tests: hidden_tests_tests, + hints: spec.hidden_tests.hints, + }, + syntax_tests: spec.syntax_tests, + }; +}; diff --git a/src/haz3lweb/ExerciseUtil.re b/src/haz3lweb/exercises/ExerciseUtil.re similarity index 100% rename from src/haz3lweb/ExerciseUtil.re rename to src/haz3lweb/exercises/ExerciseUtil.re diff --git a/src/haz3lschool/Gradescope.re b/src/haz3lweb/exercises/Gradescope.re similarity index 69% rename from src/haz3lschool/Gradescope.re rename to src/haz3lweb/exercises/Gradescope.re index 7277fcf85b..771ab5f067 100644 --- a/src/haz3lschool/Gradescope.re +++ b/src/haz3lweb/exercises/Gradescope.re @@ -1,20 +1,16 @@ +open Haz3lweb; open Haz3lcore; open Util; - -open Haz3lschool; open Core; - +open Exercise; +open Grading; open Specs; -open GradePrelude.Exercise; -open GradePrelude.Grading; - [@deriving (sexp, yojson)] type item = { max: int, percentage, src: string, }; - let item_to_summary = (name, {max, percentage, src}) => Printf.sprintf( "%s: %.1f/%.1f\n\n", @@ -29,7 +25,6 @@ let item_to_summary = (name, {max, percentage, src}) => "Source Code:\n\n" ++ src ++ "\n\n"; } ); - [@deriving (sexp, yojson)] type report = { summary: string, @@ -40,37 +35,44 @@ type section = { name: string, report, }; - [@deriving (sexp, yojson)] type chapter = list(section); - module Main = { let settings = CoreSettings.on; /* Statics and Dynamics on */ let name_to_exercise_export = path => { - let yj = Yojson.Safe.from_file(path); - switch (yj) { - | `Assoc(l) => - let sch = List.Assoc.find_exn(~equal=String.(==), l, "school"); - switch (sch) { - | `String(sch) => - let exercise_export = sch |> deserialize_exercise_export; - exercise_export; - | _ => failwith("School is not a string") - }; - | _ => failwith("Json without school key") - }; + let all = path |> Yojson.Safe.from_file |> Export.all_of_yojson; + all.exercise + |> Sexp.of_string + |> ExercisesMode.Store.exercise_export_of_sexp; }; - let gen_grading_report = exercise => { + let gen_grading_report = (exercise): report => { let zipper_pp = zipper => { Printer.pretty_print(zipper); }; - let model_results = - spliced_elabs(settings, exercise) - |> ModelResults.init_eval - |> ModelResults.run_pending(~settings); - let stitched_dynamics = - stitch_dynamic(settings, exercise, Some(model_results)); - let grading_report = exercise.eds |> GradingReport.mk(~stitched_dynamics); + let terms = + stitch_term(exercise.eds) + |> map_stitched((_, {term, _}: TermItem.t) => term); + let stitched_tests = + map_stitched( + (_, term) => + term + |> CachedStatics.init_from_term(~settings) + |> ((x: CachedStatics.t) => x.elaborated) + |> Evaluator.evaluate(~settings, ~env=Builtins.env_init) + |> ProgramResult.map(x => + x + |> ProgramResult.get_state + |> EvaluatorState.get_tests + |> TestResults.mk_results + ) + |> ( + fun + | ResultOk(x) => Some(x) + | _ => None + ), + terms, + ); + let grading_report = exercise.eds |> GradingReport.mk(~stitched_tests); let details = grading_report; let point_distribution = details.point_distribution; let test_validation = { @@ -111,14 +113,11 @@ module Main = { |> List.map(~f=(((name, _) as key, persistent_state)) => { switch (find_key_opt(key, specs)) { | Some((_n, spec)) => - let exercise = - unpersist_state( - persistent_state, - ~settings, - ~spec, - ~instructor_mode=true, - ); - let report = exercise |> gen_grading_report; + let spec = + unpersist(persistent_state, spec, ~instructor_mode=true); + let report = + {eds: spec |> eds_of_spec(~settings=CoreSettings.on)} + |> gen_grading_report; {name, report}; | None => failwith("Invalid spec") // | None => (key |> yojson_of_key |> Yojson.Safe.to_string, "?") @@ -130,5 +129,4 @@ module Main = { |> print_endline; }; }; - Main.run(); diff --git a/src/haz3lweb/Grading.re b/src/haz3lweb/exercises/Grading.re similarity index 53% rename from src/haz3lweb/Grading.re rename to src/haz3lweb/exercises/Grading.re index e16827b918..d3256e427e 100644 --- a/src/haz3lweb/Grading.re +++ b/src/haz3lweb/exercises/Grading.re @@ -1,7 +1,20 @@ +open Haz3lcore; +open Util; open Virtual_dom.Vdom; open Node; +open Exercise; -include Haz3lschool.Grading.F(Exercise.ExerciseEnv); +[@deriving (show({with_path: false}), sexp, yojson)] +type percentage = float; +[@deriving (show({with_path: false}), sexp, yojson)] +type points = float; +[@deriving (show({with_path: false}), sexp, yojson)] +type score = (points, points); + +let score_of_percent = (percent, max_points) => { + let max_points = float_of_int(max_points); + (percent *. max_points, max_points); +}; let score_view = ((earned: points, max: points)) => { div( @@ -28,7 +41,56 @@ let percentage_view = (p: percentage) => { }; module TestValidationReport = { - include TestValidationReport; + type t = { + test_results: option(TestResults.t), + required: int, + provided: int, + }; + + let mk = (eds: eds, test_results: option(TestResults.t)) => { + { + test_results, + required: eds.your_tests.required, + provided: eds.your_tests.provided, + }; + }; + + let percentage = (report: t): percentage => { + switch (report.test_results) { + | None => 0.0 + | Some(test_results) => + let num_tests = float_of_int(test_results.total); + let required = float_of_int(report.required); + let provided = float_of_int(report.provided); + let num_passing = float_of_int(test_results.passing); + + required -. provided <= 0.0 || num_tests <= 0.0 + ? 0.0 + : num_passing + /. num_tests + *. ( + Float.max( + 0., + Float.min(num_tests -. provided, required -. provided), + ) + /. (required -. provided) + ); + }; + }; + + let test_summary_str = (test_results: TestResults.t) => { + TestResults.result_summary_str( + ~n=test_results.total, + ~p=test_results.failing, + ~q=test_results.unfinished, + ~n_str="test", + ~ns_str="tests", + ~p_str="failing", + ~q_str="indeterminate", + ~r_str="valid", + ); + }; + let textual_summary = (report: t) => { switch (report.test_results) { | None => [Node.text("No test results")] @@ -53,8 +115,9 @@ module TestValidationReport = { }; }; - let view = (~inject, report: t, max_points: int) => { - Cell.report_footer_view([ + // YourTestsValidation + let view = (~signal_jump, report: t, max_points: int) => { + CellCommon.report_footer_view([ div( ~attrs=[Attr.classes(["test-summary"])], [ @@ -67,11 +130,7 @@ module TestValidationReport = { @ Option.to_list( report.test_results |> Option.map(test_results => - TestView.test_bar( - ~inject, - ~test_results, - YourTestsValidation, - ) + TestView.test_bar(~inject_jump=signal_jump, ~test_results) ), ), ), @@ -80,8 +139,95 @@ module TestValidationReport = { }; module MutationTestingReport = { - include MutationTestingReport; - open Haz3lcore; + type t = {results: list((TestStatus.t, string))}; + + let hidden_bug_status = + ( + test_validation_data: option(TestResults.t), + hidden_bug_data: option(TestResults.t), + ) + : TestStatus.t => { + switch (test_validation_data, hidden_bug_data) { + | (None, _) + | (_, None) => Indet + | (Some(test_validation_data), Some(hidden_bug_data)) => + let validation_test_map = test_validation_data.test_map; + let hidden_bug_test_map = hidden_bug_data.test_map; + + let found = + hidden_bug_test_map + |> List.find_opt(((id, instance_reports)) => { + let status = TestMap.joint_status(instance_reports); + switch (status) { + | TestStatus.Pass + | TestStatus.Indet => false + | TestStatus.Fail => + let validation_test_reports = + validation_test_map |> TestMap.lookup(id); + switch (validation_test_reports) { + | None => false + | Some(reports) => + let status = TestMap.joint_status(reports); + switch (status) { + | TestStatus.Pass => true + | TestStatus.Fail + | TestStatus.Indet => false + }; + }; + }; + }); + switch (found) { + | None => Fail + | Some(_) => Pass + }; + }; + }; // for each hidden bug + // in the test results data, find a test ID that passes test validation but fails against + + let mk = + ( + ~test_validation, + ~hidden_bugs_state: list(wrong_impl(Editor.t)), + ~hidden_bugs, + ) + : t => { + let results = List.map(hidden_bug_status(test_validation), hidden_bugs); + let hints = + List.map( + (wrong_impl: wrong_impl(Editor.t)) => wrong_impl.hint, + hidden_bugs_state, + ); + let results = List.combine(results, hints); + {results: results}; + }; + + let percentage = (report: t): percentage => { + let results = report.results; + let num_wrong_impls = List.length(results); + let num_passed = + results + |> List.find_all(((status, _)) => status == TestStatus.Pass) + |> List.length; + switch (num_wrong_impls) { + | 0 => 1.0 + | _ => float_of_int(num_passed) /. float_of_int(num_wrong_impls) + }; + }; + + // TODO move to separate module + + let summary_str = (~total, ~found): string => { + TestResults.result_summary_str( + ~n=total, + ~p=found, + ~q=0, + ~n_str="bug", + ~ns_str="bugs", + ~p_str="exposed", + ~q_str="", + ~r_str="unrevealed", + ); + }; let summary_message = (~score, ~total, ~found): Node.t => div( @@ -89,18 +235,15 @@ module MutationTestingReport = { [score_view(score), text(summary_str(~total, ~found))], ); - let bar = (~inject, instances) => + let bar = (~inject as _, instances) => div( ~attrs=[Attr.classes(["test-bar"])], List.mapi( - (id, (status, _)) => + (_id, (status, _)) => div( ~attrs=[ Attr.classes(["segment", TestStatus.to_string(status)]), - Attr.on_click( - //TODO: wire up test ids - TestView.jump_to_test(~inject, HiddenBugs(id), Id.invalid), - ), + // TODO: Wire up test ids. ], [], ), @@ -135,14 +278,12 @@ module MutationTestingReport = { ); }; - let individual_report = (id, ~inject, ~hint: string, ~status: TestStatus.t) => + let individual_report = + (id, ~inject as _, ~hint: string, ~status: TestStatus.t) => div( ~attrs=[ Attr.classes(["test-report"]), //TODO: wire up test ids - Attr.on_click( - TestView.jump_to_test(~inject, HiddenBugs(id), Id.invalid), - ), ], [ div( @@ -240,10 +381,10 @@ module MutationTestingReport = { if (max_points == 0) { Node.div([]); } else { - Cell.panel( + CellCommon.panel( ~classes=["test-panel"], [ - Cell.caption( + CellCommon.caption( "Mutation Testing", ~rest=": Your Tests vs. Buggy Implementations (hidden)", ), @@ -255,7 +396,26 @@ module MutationTestingReport = { }; module SyntaxReport = { - include SyntaxReport; + type t = { + hinted_results: list((bool, hint)), + percentage, + }; + + let mk = (~your_impl: Editor.t, ~tests: syntax_tests): t => { + let user_impl_term = + MakeTerm.from_zip_for_sem(your_impl.state.zipper).term; + let predicates = + List.map(((_, p)) => SyntaxTest.predicate_fn(p), tests); + let hints = List.map(((h, _)) => h, tests); + let syntax_results = SyntaxTest.check(user_impl_term, predicates); + + { + hinted_results: + List.map2((r, h) => (r, h), syntax_results.results, hints), + percentage: syntax_results.percentage, + }; + }; + let individual_report = (i: int, hint: string, status: bool) => { let result_string = status ? "Pass" : "Indet"; @@ -288,10 +448,10 @@ module SyntaxReport = { }; let view = (syntax_report: t) => { - Cell.panel( + CellCommon.panel( ~classes=["test-panel"], [ - Cell.caption( + CellCommon.caption( "Syntax Validation", ~rest= ": Does your implementation satisfy the syntactic requirements?", @@ -300,7 +460,7 @@ module SyntaxReport = { ], ~footer= Some( - Cell.report_footer_view([ + CellCommon.report_footer_view([ div( ~attrs=[Attr.classes(["test-summary"])], [ @@ -322,8 +482,60 @@ module SyntaxReport = { }; module ImplGradingReport = { - open Haz3lcore; - include ImplGradingReport; + type t = { + hints: list(string), + test_results: option(TestResults.t), + hinted_results: list((TestStatus.t, string)), + }; + + let mk = (~hints: list(string), ~test_results: option(TestResults.t)): t => { + let hinted_results = + switch (test_results) { + | Some(test_results) => + let statuses = test_results.statuses; + Util.ListUtil.zip_defaults( + statuses, + hints, + Haz3lcore.TestStatus.Indet, + "No hint available.", + ); + + | None => + Util.ListUtil.zip_defaults( + [], + hints, + Haz3lcore.TestStatus.Indet, + "Exercise configuration error: Hint without a test.", + ) + }; + {hints, test_results, hinted_results}; + }; + + let total = (report: t) => List.length(report.hinted_results); + let num_passed = (report: t) => { + report.hinted_results + |> List.find_all(((status, _)) => status == TestStatus.Pass) + |> List.length; + }; + + let percentage = (report: t, syntax_report: SyntaxReport.t): percentage => { + syntax_report.percentage + *. (float_of_int(num_passed(report)) /. float_of_int(total(report))); + }; + + let test_summary_str = (test_results: TestResults.t) => { + TestResults.result_summary_str( + ~n=test_results.total, + ~p=test_results.failing, + ~q=test_results.unfinished, + ~n_str="test", + ~ns_str="tests", + ~p_str="failing", + ~q_str="indeterminate", + ~r_str="valid", + ); + }; + let textual_summary = (report: t) => { switch (report.test_results) { | None => [Node.text("No test results")] @@ -360,11 +572,11 @@ module ImplGradingReport = { // ); // }; - let individual_report = (i, ~inject, ~hint: string, ~status, (id, _)) => + let individual_report = (i, ~signal_jump, ~hint: string, ~status, (id, _)) => div( ~attrs=[ Attr.classes(["test-report"]), - Attr.on_click(TestView.jump_to_test(~inject, HiddenTests, id)), + Attr.on_click(_ => signal_jump(id)), ], [ div( @@ -393,7 +605,7 @@ module ImplGradingReport = { ], ); - let individual_reports = (~inject, ~report) => { + let individual_reports = (~signal_jump, ~report) => { switch (report.test_results) { | Some(test_results) when @@ -406,7 +618,7 @@ module ImplGradingReport = { |> List.mapi((i, (status, hint)) => individual_report( i, - ~inject, + ~signal_jump, ~hint, ~status, List.nth(test_results.test_map, i), @@ -417,20 +629,26 @@ module ImplGradingReport = { }; }; + // HiddenTests let view = - (~inject, ~report: t, ~syntax_report: SyntaxReport.t, ~max_points: int) => { - Cell.panel( + ( + ~signal_jump, + ~report: t, + ~syntax_report: SyntaxReport.t, + ~max_points: int, + ) => { + CellCommon.panel( ~classes=["cell-item", "panel", "test-panel"], [ - Cell.caption( + CellCommon.caption( "Implementation Grading", ~rest=": Hidden Tests vs. Your Implementation", ), - individual_reports(~inject, ~report), + individual_reports(~signal_jump, ~report), ], ~footer= Some( - Cell.report_footer_view([ + CellCommon.report_footer_view([ div( ~attrs=[Attr.classes(["test-summary"])], [ @@ -450,7 +668,10 @@ module ImplGradingReport = { @ Option.to_list( report.test_results |> Option.map(test_results => - TestView.test_bar(~inject, ~test_results, HiddenTests) + TestView.test_bar( + ~inject_jump=signal_jump, + ~test_results, + ) ), ), ), @@ -461,7 +682,64 @@ module ImplGradingReport = { }; module GradingReport = { - include GradingReport; + type t = { + point_distribution, + test_validation_report: TestValidationReport.t, + mutation_testing_report: MutationTestingReport.t, + syntax_report: SyntaxReport.t, + impl_grading_report: ImplGradingReport.t, + }; + + let mk = (eds: eds, ~stitched_tests: stitched(option(TestResults.t))) => { + point_distribution: eds.point_distribution, + test_validation_report: + TestValidationReport.mk(eds, stitched_tests.test_validation), + mutation_testing_report: + MutationTestingReport.mk( + ~test_validation=stitched_tests.test_validation, + ~hidden_bugs_state=eds.hidden_bugs, + ~hidden_bugs=stitched_tests.hidden_bugs, + ), + syntax_report: + SyntaxReport.mk(~your_impl=eds.your_impl, ~tests=eds.syntax_tests), + impl_grading_report: + ImplGradingReport.mk( + ~hints=eds.hidden_tests.hints, + ~test_results=stitched_tests.hidden_tests, + ), + }; + + let overall_score = + ( + { + point_distribution, + test_validation_report, + mutation_testing_report, + syntax_report, + impl_grading_report, + _, + }: t, + ) + : score => { + let (tv_points, tv_max) = + score_of_percent( + TestValidationReport.percentage(test_validation_report), + point_distribution.test_validation, + ); + let (mt_points, mt_max) = + score_of_percent( + MutationTestingReport.percentage(mutation_testing_report), + point_distribution.mutation_testing, + ); + let (ig_points, ig_max) = + score_of_percent( + ImplGradingReport.percentage(impl_grading_report, syntax_report), + point_distribution.impl_grading, + ); + let total_points = tv_points +. mt_points +. ig_points; + let max_points = tv_max +. mt_max +. ig_max; + (total_points, max_points); + }; let view_overall_score = (report: t) => { score_view(overall_score(report)); diff --git a/src/haz3lschool/Specs.re b/src/haz3lweb/exercises/Specs.re similarity index 100% rename from src/haz3lschool/Specs.re rename to src/haz3lweb/exercises/Specs.re diff --git a/src/haz3lschool/SyntaxTest.re b/src/haz3lweb/exercises/SyntaxTest.re similarity index 100% rename from src/haz3lschool/SyntaxTest.re rename to src/haz3lweb/exercises/SyntaxTest.re diff --git a/src/haz3lweb/exercises/A-Guide-To-Zipper-Transitions.md b/src/haz3lweb/exercises/examples/A-Guide-To-Zipper-Transitions.md similarity index 100% rename from src/haz3lweb/exercises/A-Guide-To-Zipper-Transitions.md rename to src/haz3lweb/exercises/examples/A-Guide-To-Zipper-Transitions.md diff --git a/src/haz3lweb/exercises/BlankTemplate.ml b/src/haz3lweb/exercises/examples/BlankTemplate.ml similarity index 100% rename from src/haz3lweb/exercises/BlankTemplate.ml rename to src/haz3lweb/exercises/examples/BlankTemplate.ml diff --git a/src/haz3lweb/exercises/Ex_OddlyRecursive.ml b/src/haz3lweb/exercises/examples/Ex_OddlyRecursive.ml similarity index 99% rename from src/haz3lweb/exercises/Ex_OddlyRecursive.ml rename to src/haz3lweb/exercises/examples/Ex_OddlyRecursive.ml index 3d4ae0ce35..809427ef1f 100644 --- a/src/haz3lweb/exercises/Ex_OddlyRecursive.ml +++ b/src/haz3lweb/exercises/examples/Ex_OddlyRecursive.ml @@ -3108,6 +3108,5 @@ let exercise : Exercise.spec = }; hints = [ "zero" ]; }; - syntax_tests = - [ ("odd is recursive", Haz3lschool.SyntaxTest.IsRecursive "odd") ]; + syntax_tests = [ ("odd is recursive", SyntaxTest.IsRecursive "odd") ]; } diff --git a/src/haz3lweb/exercises/Ex_OddlyRecursive_prompt.re b/src/haz3lweb/exercises/examples/Ex_OddlyRecursive_prompt.re similarity index 100% rename from src/haz3lweb/exercises/Ex_OddlyRecursive_prompt.re rename to src/haz3lweb/exercises/examples/Ex_OddlyRecursive_prompt.re diff --git a/src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml b/src/haz3lweb/exercises/examples/Ex_RecursiveFibonacci.ml similarity index 99% rename from src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml rename to src/haz3lweb/exercises/examples/Ex_RecursiveFibonacci.ml index cdcf9cb651..61839b5a46 100644 --- a/src/haz3lweb/exercises/Ex_RecursiveFibonacci.ml +++ b/src/haz3lweb/exercises/examples/Ex_RecursiveFibonacci.ml @@ -3116,6 +3116,5 @@ let exercise : Exercise.spec = }; hints = []; }; - syntax_tests = - [ ("fib is recursive", Haz3lschool.SyntaxTest.IsRecursive "fib") ]; + syntax_tests = [ ("fib is recursive", SyntaxTest.IsRecursive "fib") ]; } diff --git a/src/haz3lweb/exercises/Ex_RecursiveFibonacci_prompt.re b/src/haz3lweb/exercises/examples/Ex_RecursiveFibonacci_prompt.re similarity index 100% rename from src/haz3lweb/exercises/Ex_RecursiveFibonacci_prompt.re rename to src/haz3lweb/exercises/examples/Ex_RecursiveFibonacci_prompt.re diff --git a/src/haz3lweb/ExerciseSettings.re b/src/haz3lweb/exercises/settings/ExerciseSettings.re similarity index 100% rename from src/haz3lweb/ExerciseSettings.re rename to src/haz3lweb/exercises/settings/ExerciseSettings.re diff --git a/src/haz3lweb/ExerciseSettings_base.re b/src/haz3lweb/exercises/settings/ExerciseSettings_base.re similarity index 100% rename from src/haz3lweb/ExerciseSettings_base.re rename to src/haz3lweb/exercises/settings/ExerciseSettings_base.re diff --git a/src/haz3lweb/ExerciseSettings_instructor.re b/src/haz3lweb/exercises/settings/ExerciseSettings_instructor.re similarity index 100% rename from src/haz3lweb/ExerciseSettings_instructor.re rename to src/haz3lweb/exercises/settings/ExerciseSettings_instructor.re diff --git a/src/haz3lweb/ExerciseSettings_student.re b/src/haz3lweb/exercises/settings/ExerciseSettings_student.re similarity index 100% rename from src/haz3lweb/ExerciseSettings_student.re rename to src/haz3lweb/exercises/settings/ExerciseSettings_student.re diff --git a/src/haz3lweb/explainthis/ExplainThisUpdate.re b/src/haz3lweb/explainthis/ExplainThisUpdate.re index 8946a4818c..d0bd4fedff 100644 --- a/src/haz3lweb/explainthis/ExplainThisUpdate.re +++ b/src/haz3lweb/explainthis/ExplainThisUpdate.re @@ -1,6 +1,6 @@ -open Util; open ExplainThisForm; open ExplainThisModel; +open Util; [@deriving (show({with_path: false}), sexp, yojson)] type update = @@ -10,77 +10,81 @@ type update = | UpdateGroupSelection(group_id, form_id); let set_update = - (explainThisModel: ExplainThisModel.t, u: update): ExplainThisModel.t => { - switch (u) { - | SpecificityOpen(b) => {...explainThisModel, specificity_open: b} - | ToggleExplanationFeedback(group_id, form_id, feedback_option) => - let (pre, form, post) = - ListUtil.split(explainThisModel.forms, f => - f.form == form_id && f.group == group_id - ); - let form = - switch (form) { - | Some(form) => - let feedback = - switch (form.explanation_feedback, feedback_option) { - | (Some(ThumbsUp), ThumbsDown) - | (Some(ThumbsDown), ThumbsUp) - | (None, _) => Some(feedback_option) - | (Some(ThumbsUp), ThumbsUp) - | (Some(ThumbsDown), ThumbsDown) => None - }; - {...form, explanation_feedback: feedback}; - | None => { - group: group_id, - form: form_id, - explanation_feedback: Some(feedback_option), - examples: [], - } - }; - {...explainThisModel, forms: pre @ [form] @ post}; - | ToggleExampleFeedback(group_id, form_id, example_id, feedback_option) => - let (pre_form, form, post_form) = - ListUtil.split(explainThisModel.forms, f => - f.form == form_id && f.group == group_id - ); - let form: form_model = - switch (form) { - | Some(form) => - let (pre_example, example, post_example) = - ListUtil.split(form.examples, e => e.sub_id == example_id); - let examples: list(example_model) = - switch (example) { - | Some(example) => - switch (example.feedback, feedback_option) { - | (ThumbsUp, ThumbsDown) - | (ThumbsDown, ThumbsUp) => + (explainThisModel: ExplainThisModel.t, u: update) + : Updated.t(ExplainThisModel.t) => { + ( + switch (u) { + | SpecificityOpen(b) => {...explainThisModel, specificity_open: b} + | ToggleExplanationFeedback(group_id, form_id, feedback_option) => + let (pre, form, post) = + ListUtil.split(explainThisModel.forms, f => + f.form == form_id && f.group == group_id + ); + let form = + switch (form) { + | Some(form) => + let feedback = + switch (form.explanation_feedback, feedback_option) { + | (Some(ThumbsUp), ThumbsDown) + | (Some(ThumbsDown), ThumbsUp) + | (None, _) => Some(feedback_option) + | (Some(ThumbsUp), ThumbsUp) + | (Some(ThumbsDown), ThumbsDown) => None + }; + {...form, explanation_feedback: feedback}; + | None => { + group: group_id, + form: form_id, + explanation_feedback: Some(feedback_option), + examples: [], + } + }; + {...explainThisModel, forms: pre @ [form] @ post}; + | ToggleExampleFeedback(group_id, form_id, example_id, feedback_option) => + let (pre_form, form, post_form) = + ListUtil.split(explainThisModel.forms, f => + f.form == form_id && f.group == group_id + ); + let form: form_model = + switch (form) { + | Some(form) => + let (pre_example, example, post_example) = + ListUtil.split(form.examples, e => e.sub_id == example_id); + let examples: list(example_model) = + switch (example) { + | Some(example) => + switch (example.feedback, feedback_option) { + | (ThumbsUp, ThumbsDown) + | (ThumbsDown, ThumbsUp) => + pre_example + @ [{...example, feedback: feedback_option}] + @ post_example + | (ThumbsUp, ThumbsUp) + | (ThumbsDown, ThumbsDown) => pre_example @ post_example + } + | None => pre_example - @ [{...example, feedback: feedback_option}] + @ [{sub_id: example_id, feedback: feedback_option}] @ post_example - | (ThumbsUp, ThumbsUp) - | (ThumbsDown, ThumbsDown) => pre_example @ post_example - } - | None => - pre_example - @ [{sub_id: example_id, feedback: feedback_option}] - @ post_example - }; - {...form, examples}; - | None => { - group: group_id, - form: form_id, - explanation_feedback: None, - examples: [{sub_id: example_id, feedback: feedback_option}], - } + }; + {...form, examples}; + | None => { + group: group_id, + form: form_id, + explanation_feedback: None, + examples: [{sub_id: example_id, feedback: feedback_option}], + } + }; + {...explainThisModel, forms: pre_form @ [form] @ post_form}; + | UpdateGroupSelection(group_id, form_id) => + let (pre_group, _group, post_group) = + ListUtil.split(explainThisModel.groups, g => g.group == group_id); + { + ...explainThisModel, + groups: + pre_group @ [{group: group_id, selected: form_id}] @ post_group, }; - {...explainThisModel, forms: pre_form @ [form] @ post_form}; - | UpdateGroupSelection(group_id, form_id) => - let (pre_group, _group, post_group) = - ListUtil.split(explainThisModel.groups, g => g.group == group_id); - { - ...explainThisModel, - groups: - pre_group @ [{group: group_id, selected: form_id}] @ post_group, - }; - }; + } + ) + |> Updated.return_quiet(~logged=true); }; diff --git a/src/haz3lweb/util/WorkerServer.re b/src/haz3lweb/util/WorkerServer.re index debb55a537..8c988d7a51 100644 --- a/src/haz3lweb/util/WorkerServer.re +++ b/src/haz3lweb/util/WorkerServer.re @@ -4,35 +4,50 @@ open Util; type key = string; module Request = { - [@deriving (sexp, yojson)] - type value = Haz3lcore.ModelResults.t; - [@deriving (sexp, yojson)] - type t = value; + [@deriving (show, sexp, yojson)] + type value = Haz3lcore.Exp.t; + [@deriving (show, sexp, yojson)] + type t = list((string, value)); let serialize = program => program |> sexp_of_t |> Sexplib.Sexp.to_string; let deserialize = sexp => sexp |> Sexplib.Sexp.of_string |> t_of_sexp; }; module Response = { - [@deriving (sexp, yojson)] - type value = Haz3lcore.ModelResults.t; - [@deriving (sexp, yojson)] - type t = value; + [@deriving (show, sexp, yojson)] + type value = + Result.t( + (Haz3lcore.ProgramResult.Result.t, Haz3lcore.EvaluatorState.t), + Haz3lcore.ProgramResult.error, + ); + [@deriving (show, sexp, yojson)] + type t = list((string, value)); let serialize = r => r |> sexp_of_t |> Sexplib.Sexp.to_string; let deserialize = sexp => sexp |> Sexplib.Sexp.of_string |> t_of_sexp; }; let work = (res: Request.value): Response.value => - Haz3lcore.ModelResults.run_pending( - ~settings=Haz3lcore.CoreSettings.on, - res, - ); + switch ( + Haz3lcore.Evaluator.evaluate'(Haz3lcore.Builtins.env_init, {d: res}) + ) { + | exception (Haz3lcore.EvaluatorError.Exception(reason)) => + print_endline( + "EvaluatorError:" ++ Haz3lcore.EvaluatorError.show(reason), + ); + Error(Haz3lcore.ProgramResult.EvaulatorError(reason)); + | exception exn => + print_endline("EXN:" ++ Printexc.to_string(exn)); + Error( + Haz3lcore.ProgramResult.UnknownException(Printexc.to_string(exn)), + ); + | (state, result) => Ok((result, state)) + }; let on_request = (req: string): unit => req |> Request.deserialize - |> work + |> List.map(((k, v)) => (k, work(v))) |> Response.serialize |> Js_of_ocaml.Worker.post_message; diff --git a/src/haz3lweb/view/Cell.re b/src/haz3lweb/view/Cell.re deleted file mode 100644 index ba06d2a29e..0000000000 --- a/src/haz3lweb/view/Cell.re +++ /dev/null @@ -1,445 +0,0 @@ -open Util; -open Virtual_dom.Vdom; -open Haz3lcore; -open Node; - -let get_goal = (~font_metrics: FontMetrics.t, ~target_id, e) => { - let rect = JsUtil.get_elem_by_id(target_id)##getBoundingClientRect; - let goal_x = float_of_int(e##.clientX); - let goal_y = float_of_int(e##.clientY); - Point.{ - row: Float.to_int((goal_y -. rect##.top) /. font_metrics.row_height), - col: - Float.( - to_int(round((goal_x -. rect##.left) /. font_metrics.col_width)) - ), - }; -}; - -let mousedown_overlay = (~inject, ~font_metrics, ~target_id) => - div( - ~attrs= - Attr.[ - id("mousedown-overlay"), - on_mouseup(_ => inject(Update.SetMeta(Mouseup))), - on_mousemove(e => { - let goal = get_goal(~font_metrics, ~target_id, e); - inject( - Update.PerformAction(Select(Resize(Goal(Point(goal))))), - ); - }), - ], - [], - ); - -let mousedown_handler = - ( - ~inject: UpdateAction.t => 'a, - ~font_metrics, - ~target_id, - ~mousedown_updates, - evt, - ) => - switch (JsUtil.ctrl_held(evt), JsUtil.num_clicks(evt)) { - | (true, _) => - let goal = get_goal(~font_metrics, ~target_id, evt); - let events = [ - inject(PerformAction(Move(Goal(Point(goal))))), - inject(PerformAction(Jump(BindingSiteOfIndicatedVar))), - ]; - Virtual_dom.Vdom.Effect.Many(events); - | (false, 1) => - let goal = get_goal(~font_metrics, ~target_id, evt); - /* Note that we only trigger drag mode (set mousedown) - * when the left mouse button (aka button 0) is pressed */ - Virtual_dom.Vdom.Effect.Many( - List.map( - inject, - Update.( - (JsUtil.mouse_button(evt) == 0 ? [SetMeta(Mousedown)] : []) - @ mousedown_updates - @ [PerformAction(Move(Goal(Point(goal))))] - ), - ), - ); - | (false, n) => inject(PerformAction(Select(Smart(n)))) - }; - -let narrative_cell = (content: Node.t) => - div( - ~attrs=[Attr.class_("cell")], - [div(~attrs=[Attr.class_("cell-chapter")], [content])], - ); - -let simple_cell_item = (content: list(Node.t)) => - div(~attrs=[Attr.classes(["cell-item"])], content); - -let caption = (~rest: option(string)=?, bolded: string) => - div( - ~attrs=[Attr.classes(["cell-caption"])], - [strong([text(bolded)])] @ (rest |> Option.map(text) |> Option.to_list), - ); - -let simple_cell_view = (items: list(t)) => - div(~attrs=[Attr.class_("cell")], items); - -let test_status_icon_view = - (~font_metrics, insts, ms: Measured.Shards.t): option(t) => - switch (ms) { - | [(_, {origin: _, last}), ..._] => - let status = insts |> TestMap.joint_status |> TestStatus.to_string; - let pos = DecUtil.abs_position(~font_metrics, last); - Some(div(~attrs=[Attr.classes(["test-result", status]), pos], [])); - | _ => None - }; - -let test_result_layer = - (~font_metrics, ~measured: Measured.t, test_results: TestResults.t): t => - Web.div_c( - "test-decos", - List.filter_map( - ((id, insts)) => - switch (Id.Map.find_opt(id, measured.tiles)) { - | Some(ms) => test_status_icon_view(~font_metrics, insts, ms) - | None => None - }, - test_results.test_map, - ), - ); - -let deco = - ( - ~inject, - ~ui_state, - ~selected, - ~test_results: option(TestResults.t), - ~highlights: option(ColorSteps.colorMap), - z, - meta: Editor.Meta.t, - ) => { - module Deco = - Deco.Deco({ - let ui_state = ui_state; - let meta = meta; - let highlights = highlights; - }); - let decos = selected ? Deco.all(z) : Deco.always(); - let decos = - decos - @ [ - ProjectorView.all( - z, - ~meta, - ~inject, - ~font_metrics=ui_state.font_metrics, - ), - ]; - switch (test_results) { - | None => decos - | Some(test_results) => - decos - @ [ - test_result_layer( - ~font_metrics=ui_state.font_metrics, - ~measured=meta.syntax.measured, - test_results, - ), - ] // TODO move into decos - }; -}; - -let error_msg = (err: ProgramResult.error) => - switch (err) { - | EvaulatorError(err) => EvaluatorError.show(err) - | UnknownException(str) => str - | Timeout => "Evaluation timed out" - }; - -let status_of: ProgramResult.t => string = - fun - | ResultPending => "pending" - | ResultOk(_) => "ok" - | ResultFail(_) => "fail" - | Off(_) => "off"; - -let live_eval = - ( - ~inject, - ~ui_state as {font_metrics, _}: Model.ui_state, - ~result_key: string, - ~settings: Settings.t, - ~locked, - result: ModelResult.eval_result, - ) => { - open Node; - let dhexp = - switch (result.evaluation, result.previous) { - | (ResultOk(res), _) => ProgramResult.get_dhexp(res) - | (ResultPending, ResultOk(res)) => ProgramResult.get_dhexp(res) - | _ => result.elab.d - }; - let dhcode_view = - DHCode.view( - ~locked, - ~inject, - ~settings=settings.core.evaluation, - ~selected_hole_instance=None, - ~font_metrics, - ~width=80, - ~result_key, - ~infomap=Id.Map.empty, - dhexp, - ); - let exn_view = - switch (result.evaluation) { - | ResultFail(err) => [ - div( - ~attrs=[Attr.classes(["error-msg"])], - [text(error_msg(err))], - ), - ] - | _ => [] - }; - div( - ~attrs=[Attr.classes(["cell-item", "cell-result"])], - exn_view - @ [ - div( - ~attrs=[Attr.classes(["status", status_of(result.evaluation)])], - [ - div(~attrs=[Attr.classes(["spinner"])], []), - div(~attrs=[Attr.classes(["eq"])], [text("≡")]), - ], - ), - div( - ~attrs=[Attr.classes(["result", status_of(result.evaluation)])], - [dhcode_view], - ), - Widgets.toggle(~tooltip="Show Stepper", "s", false, _ => - inject(UpdateAction.ToggleStepper(result_key)) - ), - ], - ); -}; - -let footer = - ( - ~locked, - ~inject, - ~ui_state as {font_metrics, _} as ui_state: Model.ui_state, - ~settings: Settings.t, - ~result: ModelResult.t, - ~result_key, - ) => - switch (result) { - | _ when !settings.core.dynamics => [] - | NoElab => [] - | Evaluation(result) => [ - live_eval(~locked, ~inject, ~ui_state, ~settings, ~result_key, result), - ] - | Stepper(s) => - StepperView.stepper_view( - ~inject, - ~settings=settings.core.evaluation, - ~font_metrics, - ~result_key, - ~read_only=false, - s, - ) - }; - -let editor_view = - ( - ~inject: UpdateAction.t => Ui_effect.t(unit), - ~ui_state: Model.ui_state, - ~settings: Settings.t, - ~target_id: string, - ~mousedown_updates: list(Update.t)=[], - ~selected: bool=true, - ~locked=false, - ~caption: option(Node.t)=?, - ~test_results: option(TestResults.t), - ~footer: option(list(Node.t))=?, - ~highlights: option(ColorSteps.colorMap), - ~overlayer: option(Node.t)=None, - ~sort=Sort.root, - ~override_statics: option(Editor.CachedStatics.t)=?, - editor: Editor.t, - ) => { - let Model.{font_metrics, mousedown, _} = ui_state; - let meta = - /* For exercises modes */ - switch (override_statics) { - | None => editor.state.meta - | Some(statics) => {...editor.state.meta, statics} - }; - let mousedown_overlay = - selected && mousedown - ? [mousedown_overlay(~inject, ~font_metrics, ~target_id)] : []; - let code_text_view = - Code.view(~sort, ~font_metrics, ~settings, editor.state.zipper, meta); - let deco_view = - deco( - ~inject, - ~ui_state, - ~selected, - ~test_results, - ~highlights, - editor.state.zipper, - meta, - ); - - let code_view = - div( - ~attrs=[Attr.id(target_id), Attr.classes(["code-container"])], - [code_text_view] - @ deco_view - @ Option.to_list(overlayer) - @ mousedown_overlay, - ); - let on_mousedown = - locked - ? _ => - Virtual_dom.Vdom.Effect.(Many([Prevent_default, Stop_propagation])) - : mousedown_handler( - ~inject, - ~font_metrics, - ~target_id, - ~mousedown_updates, - ); - div( - ~attrs=[ - Attr.classes([ - "cell", - selected ? "selected" : "deselected", - locked ? "locked" : "unlocked", - ]), - ], - [ - div( - ~attrs=[ - Attr.classes(["cell-item"]), - Attr.on_mousedown(on_mousedown), - ], - Option.to_list(caption) @ [code_view], - ), - ] - @ (footer |> Option.to_list |> List.concat), - ); -}; - -let report_footer_view = content => { - div(~attrs=[Attr.classes(["cell-item", "cell-report"])], content); -}; - -let test_report_footer_view = (~inject, ~test_results: option(TestResults.t)) => { - report_footer_view([TestView.test_summary(~inject, ~test_results)]); -}; - -let panel = (~classes=[], content, ~footer: option(t)) => { - simple_cell_view( - [ - div(~attrs=[Attr.classes(["cell-item", "panel"] @ classes)], content), - ] - @ Option.to_list(footer), - ); -}; - -let title_cell = title => { - simple_cell_view([ - div( - ~attrs=[Attr.class_("title-cell")], - [div(~attrs=[Attr.class_("title-text")], [text(title)])], - ), - ]); -}; - -/* An editor view that is not selectable or editable, - * and does not show error holes or test results. - * Used in Docs to display the header example */ -let locked_no_statics = - ( - ~inject, - ~ui_state, - ~segment, - ~highlights, - ~settings, - ~sort, - ~expander_deco, - ~target_id, - ) => [ - editor_view( - ~locked=true, - ~selected=false, - ~highlights, - ~inject, - ~ui_state, - ~settings, - ~target_id, - ~footer=[], - ~test_results=None, - ~overlayer=Some(expander_deco), - ~sort, - segment - |> Zipper.unzip - |> Editor.init(~settings=CoreSettings.off, ~read_only=true), - ), -]; - -/* An editor view that is not selectable or editable, - * but does show static errors, test results, and live values. - * Used in Docs for examples */ -let locked = - ( - ~ui_state, - ~settings: Settings.t, - ~inject, - ~target_id, - ~segment: Segment.t, - ) => { - let editor = - segment - |> Zipper.unzip - |> Editor.init(~settings=settings.core, ~read_only=true); - let statics = editor.state.meta.statics; - let elab = - settings.core.elaborate || settings.core.dynamics - ? Interface.elaborate( - ~settings=settings.core, - statics.info_map, - statics.term, - ) - : Bool(true) |> DHExp.fresh; - let elab: Elaborator.Elaboration.t = {d: elab}; - let result: ModelResult.t = - settings.core.dynamics - ? Evaluation({ - elab, - evaluation: Interface.evaluate(~settings=settings.core, elab.d), - previous: ResultPending, - }) - : NoElab; - let footer = - settings.core.elaborate || settings.core.dynamics - ? footer( - ~locked=true, - ~inject, - ~settings, - ~ui_state, - ~result_key=target_id, - ~result, - ) - : []; - editor_view( - ~locked=true, - ~selected=false, - ~highlights=None, - ~inject, - ~ui_state, - ~settings, - ~target_id, - ~footer, - ~test_results=ModelResult.test_results(result), - editor, - ); -}; diff --git a/src/haz3lweb/view/ContextInspector.re b/src/haz3lweb/view/ContextInspector.re index 672988d049..3e48eb2109 100644 --- a/src/haz3lweb/view/ContextInspector.re +++ b/src/haz3lweb/view/ContextInspector.re @@ -2,65 +2,79 @@ open Virtual_dom.Vdom; open Node; open Util.Web; +let alias_view = (s: string): Node.t => + div(~attrs=[clss(["typ-alias-view"])], [text(s)]); + let jump_to = entry => - UpdateAction.PerformAction(Jump(TileId(Haz3lcore.Ctx.get_id(entry)))); + Globals.Update.JumpToTile(Haz3lcore.Ctx.get_id(entry)); -let context_entry_view = (~inject, entry: Haz3lcore.Ctx.entry): Node.t => { +let context_entry_view = (~globals, entry: Haz3lcore.Ctx.entry): Node.t => { + let view_type = + CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ); let div_name = div(~attrs=[clss(["name"])]); switch (entry) { | VarEntry({name, typ, _}) | ConstructorEntry({name, typ, _}) => div( ~attrs=[ - Attr.on_click(_ => inject(jump_to(entry))), + Attr.on_click(_ => globals.inject_global(jump_to(entry))), clss(["context-entry", "code"]), ], [ div_name([text(name)]), div(~attrs=[clss(["seperator"])], [text(":")]), - Type.view(typ), + view_type(typ, ~info_map=Haz3lcore.Id.Map.empty), ], ) | TVarEntry({name, kind, _}) => div( ~attrs=[ - Attr.on_click(_ => inject(jump_to(entry))), + Attr.on_click(_ => globals.inject_global(jump_to(entry))), clss(["context-entry", "code"]), ], [ - div_name([Type.alias_view(name)]), + div_name([alias_view(name)]), div(~attrs=[clss(["seperator"])], [text("::")]), - Kind.view(kind), + Kind.view(~globals, kind), ], ) }; }; -let ctx_view = (~inject, ctx: Haz3lcore.Ctx.t): Node.t => +let ctx_view = (~globals, ctx: Haz3lcore.Ctx.t): Node.t => div( ~attrs=[clss(["context-inspector"])], List.map( - context_entry_view(~inject), + context_entry_view(~globals), ctx |> Haz3lcore.Ctx.filter_duplicates |> List.rev, ), ); -let ctx_sorts_view = (~inject, ci: Haz3lcore.Statics.Info.t) => +let ctx_sorts_view = (~globals, ci: Haz3lcore.Statics.Info.t) => Haz3lcore.Info.ctx_of(ci) |> Haz3lcore.Ctx.filter_duplicates |> List.rev - |> List.map(context_entry_view(~inject)); + |> List.map(context_entry_view(~globals)); let view = - (~inject, ~settings: Settings.t, ci: option(Haz3lcore.Statics.Info.t)) - : Node.t => { + (~globals: Globals.t, ci: option(Haz3lcore.Statics.Info.t)): Node.t => { let clss = clss( - ["context-inspector"] @ (settings.context_inspector ? ["visible"] : []), + ["context-inspector"] + @ (globals.settings.context_inspector ? ["visible"] : []), ); switch (ci) { - | Some(ci) when settings.context_inspector => - div(~attrs=[clss], ctx_sorts_view(~inject, ci)) + | Some(ci) when globals.settings.context_inspector => + div(~attrs=[clss], ctx_sorts_view(~globals, ci)) | _ => div([]) }; }; diff --git a/src/haz3lweb/view/EditorModeView.re b/src/haz3lweb/view/EditorModeView.re index dea884266f..8aa205d176 100644 --- a/src/haz3lweb/view/EditorModeView.re +++ b/src/haz3lweb/view/EditorModeView.re @@ -1,6 +1,7 @@ open Virtual_dom.Vdom; open Node; open Widgets; +open Util; let option_view = (name, n) => option( @@ -8,125 +9,31 @@ let option_view = (name, n) => [text(n)], ); -let mode_menu = (~inject: Update.t => 'a, ~mode: Settings.mode) => - div( - ~attrs=[Attr.class_("mode-name"), Attr.title("Toggle Mode")], - [ - select( - ~attrs=[ - Attr.on_change((_, name) => - inject(Set(Mode(Settings.mode_of_string(name)))) - ), - ], - List.map( - option_view(Settings.show_mode(mode)), - ["Scratch", "Documentation", "Exercises"], - ), +type event = + | Previous + | Next; + +let view = (~signal: event => 'a, ~indicator: list(Node.t)) => + [button(Icons.back, _ => signal(Previous))] + @ indicator + @ [button(Icons.forward, _ => signal(Next))]; + +let indicator_n = (cur_slide, num_slides) => [ + text(Printf.sprintf("%d / %d", cur_slide + 1, num_slides)), +]; + +let indicator_select = (~signal: int => 'a, cur_slide, names) => [ + select( + ~attrs=[ + Attr.on_change((_, name) => + signal( + ListUtil.findi_opt(n => n == name, names) |> Option.get |> fst, + ) ), ], - ); - -let slide_select = (~inject, ~cur_slide, ~num_slides) => { - let next_ed = (cur_slide + 1) mod num_slides; - let prev_ed = Util.IntUtil.modulo(cur_slide - 1, num_slides); - [ - button(Icons.back, _ => inject(Update.SwitchScratchSlide(prev_ed))), - text(Printf.sprintf("%d / %d", cur_slide + 1, num_slides)), - button(Icons.forward, _ => inject(Update.SwitchScratchSlide(next_ed))), - ]; -}; - -let scratch_view = (~inject, ~cur_slide, ~slides) => - [text("/"), mode_menu(~inject, ~mode=Scratch), text("/")] - @ slide_select(~inject, ~cur_slide, ~num_slides=List.length(slides)); - -let documentation_view = (~inject, ~name, ~editors) => { - let editor_names = List.map(fst, editors); - let rec find_prev_next: list(string) => (option(string), option(string)) = - fun - | [] - | [_] => (None, None) - | [x, y] when name == x => (None, Some(y)) - | [x, y] when name == y => (Some(x), None) - | [_, _] => (None, None) - | [x, y, ..._] when name == x => (None, Some(y)) - | [x, y, z, ..._] when name == y => (Some(x), Some(z)) - | [_, ...ys] => find_prev_next(ys); - let (prev, next) = find_prev_next(editor_names); - let _prev = - prev - |> Option.map(s => - button(Icons.back, _ => inject(Update.SwitchDocumentationSlide(s))) - ) - |> Option.value( - ~default= - button_d( - Icons.back, - inject(Update.SwitchDocumentationSlide("none")), - ~disabled=true, - ), - ); - let _next = - next - |> Option.map(s => - button(Icons.forward, _ => - inject(Update.SwitchDocumentationSlide(s)) - ) - ) - |> Option.value( - ~default= - button_d( - Icons.forward, - inject(Update.SwitchDocumentationSlide("none")), - ~disabled=true, - ), - ); - [ - text("/"), - mode_menu(~inject, ~mode=Documentation), - text("/"), - select( - ~attrs=[ - Attr.on_change((_, name) => - inject(Update.SwitchDocumentationSlide(name)) - ), - ], - List.map(option_view(name), editor_names), + List.mapi( + (i, name) => option_view(i == cur_slide ? name : name ++ "+", name), + names, ), - ]; -}; - -let instructor_toggle = (~inject, ~instructor_mode) => - ExerciseSettings.show_instructor - ? [ - toggle("🎓", ~tooltip="Toggle Instructor Mode", instructor_mode, _ => - inject(Update.Set(InstructorMode)) - ), - ] - : []; - -let exercises_view = (~inject, ~cur_slide, ~specs, ~instructor_mode) => { - [text("/"), mode_menu(~inject, ~mode=Exercises), text("/")] - @ instructor_toggle(~inject, ~instructor_mode) - @ [text("/")] - @ slide_select(~inject, ~cur_slide, ~num_slides=List.length(specs)); -}; - -let view = - ( - ~inject: Update.t => 'a, - ~editors: Editors.t, - ~settings as {instructor_mode, _}: Settings.t, - ) - : Node.t => { - let contents = - switch (editors) { - | Scratch(cur_slide, slides) => - scratch_view(~inject, ~cur_slide, ~slides) - | Documentation(name, editors) => - documentation_view(~inject, ~name, ~editors) - | Exercises(cur_slide, specs, _) => - exercises_view(~cur_slide, ~specs, ~inject, ~instructor_mode) - }; - div(~attrs=[Attr.id("editor-mode")], contents); -}; + ), +]; diff --git a/src/haz3lweb/view/ExerciseMode.re b/src/haz3lweb/view/ExerciseMode.re index 2b291c99f4..d8bc55fafa 100644 --- a/src/haz3lweb/view/ExerciseMode.re +++ b/src/haz3lweb/view/ExerciseMode.re @@ -1,318 +1,549 @@ -open Util; open Haz3lcore; open Virtual_dom.Vdom; open Node; -type vis_marked('a) = - | InstructorOnly(unit => 'a) - | Always('a); +/* The exercises mode interface for a single exercise. Composed of multiple editors and results. */ -let render_cells = (settings: Settings.t, v: list(vis_marked(Node.t))) => { - List.filter_map( - vis => - switch (vis) { - | InstructorOnly(f) => settings.instructor_mode ? Some(f()) : None - | Always(node) => Some(node) - }, - v, - ); -}; +/* This file follows conventions in [docs/ui-architecture.md] */ -let view = - ( - ~inject, - ~ui_state: Model.ui_state, - ~settings: Settings.t, - ~exercise, - ~stitched_dynamics, - ~highlights, - ) => { - let Exercise.{eds, pos} = exercise; - let { - test_validation, - user_impl, - user_tests, - prelude, - instructor, - hidden_bugs, - hidden_tests: _, - }: - Exercise.stitched(Exercise.DynamicsItem.t) = stitched_dynamics; - let grading_report = Grading.GradingReport.mk(eds, ~stitched_dynamics); - let score_view = Grading.GradingReport.view_overall_score(grading_report); - let editor_view = - ( - ~editor: Editor.t, - ~caption: string, - ~subcaption: option(string)=?, - ~footer=?, - ~di: Exercise.DynamicsItem.t, - this_pos, - ) => { - Cell.editor_view( - ~selected=pos == this_pos, - ~override_statics=di.statics, - ~inject, - ~ui_state, - ~mousedown_updates=[SwitchEditor(this_pos)], - ~settings, - ~highlights, - ~caption=Cell.caption(caption, ~rest=?subcaption), - ~target_id=Exercise.show_pos(this_pos), - ~test_results=ModelResult.test_results(di.result), - ~footer?, - editor, - ); +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + spec: Exercise.spec, // The spec that the model will be reset to on ResetExercise + /* We keep a separate editors field below (even though each cell technically also has its own editor) + for two reasons: + 1. There are two synced cells that have the same internal `editor` model + 2. The editors need to be `stitched` together before any cell calculations can be done */ + editors: Exercise.p(Editor.t), + cells: Exercise.stitched(CellEditor.Model.t), }; - let title_view = Cell.title_cell(eds.title); - let prompt_view = - Cell.narrative_cell( - div(~attrs=[Attr.class_("cell-prompt")], [eds.prompt]), - ); - let prelude_view = - Always( - editor_view( - Prelude, - ~caption="Prelude", - ~subcaption=settings.instructor_mode ? "" : " (Read-Only)", - ~editor=eds.prelude, - ~di=prelude, - ), - ); + let of_spec = (~settings as _, ~instructor_mode as _: bool, spec) => { + let editors = Exercise.map(spec, Editor.Model.mk, Editor.Model.mk); + let term_item_to_cell = (item: Exercise.TermItem.t): CellEditor.Model.t => { + CellEditor.Model.mk(item.editor); + }; + let cells = + Exercise.stitch_term(editors) + |> Exercise.map_stitched(_ => term_item_to_cell); + {spec, editors, cells}; + }; - let correct_impl_view = - InstructorOnly( - () => - editor_view( - CorrectImpl, - ~caption="Correct Implementation", - ~editor=eds.correct_impl, - ~di=instructor, - ), - ); - // determine trailing hole - // TODO: module - let correct_impl_ctx_view = - Always( + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = Exercise.persistent_exercise_mode; + + let persist = (exercise: t, ~instructor_mode: bool) => { + Exercise.positioned_editors(exercise.editors) + |> List.filter(((pos, _)) => + Exercise.visible_in(pos, ~instructor_mode) + ) + |> List.map(((pos, editor: Editor.t)) => + (pos, editor.state.zipper |> PersistentZipper.persist) + ); + }; + + let unpersist = (~instructor_mode, positioned_zippers, spec) => { + let spec = Exercise.unpersist(~instructor_mode, positioned_zippers, spec); + of_spec(~instructor_mode, spec); + }; +}; + +module Update = { + open Updated; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Editor(Exercise.pos, CellEditor.Update.t) + | ResetEditor(Exercise.pos) + | ResetExercise; + + let update = + (~settings: Settings.t, ~schedule_action as _, action, model: Model.t) + : Updated.t(Model.t) => { + let instructor_mode = settings.instructor_mode; + switch (action) { + | Editor(pos, MainEditor(action)) + when Exercise.visible_in(pos, ~instructor_mode) => + // Redirect to editors + let editor = + Exercise.main_editor_of_state(~selection=pos, model.editors); + let* new_editor = + // Hack[Matt]: put Editor.t into a CodeEditor.t to use its update function + editor + |> CodeEditable.Model.mk + |> CodeEditable.Update.update(~settings, action); { - let exp_ctx_view = { - let correct_impl_trailing_hole_ctx = - Haz3lcore.Editor.trailing_hole_ctx( - eds.correct_impl, - instructor.statics.info_map, - ); - let prelude_trailing_hole_ctx = - Haz3lcore.Editor.trailing_hole_ctx( - eds.prelude, - prelude.statics.info_map, - ); - switch (correct_impl_trailing_hole_ctx, prelude_trailing_hole_ctx) { - | (None, _) => Node.div([text("No context available (1)")]) - | (_, None) => Node.div([text("No context available (2)")]) // TODO show exercise configuration error - | ( - Some(correct_impl_trailing_hole_ctx), - Some(prelude_trailing_hole_ctx), - ) => - let specific_ctx = - Haz3lcore.Ctx.subtract_prefix( - correct_impl_trailing_hole_ctx, - prelude_trailing_hole_ctx, - ); - switch (specific_ctx) { - | None => Node.div([text("No context available")]) // TODO show exercise configuration error - | Some(specific_ctx) => - ContextInspector.ctx_view(~inject, specific_ctx) - }; - }; - }; - Cell.simple_cell_view([ - Cell.simple_cell_item([ - Cell.caption( - "Correct Implementation", - ~rest=" (Type Signatures Only)", + ...model, + editors: + Exercise.put_main_editor( + ~selection=pos, + model.editors, + new_editor.editor, + ), + }; + | Editor(pos, MainEditor(action)) => + switch (CodeSelectable.Update.convert_action(action)) { + | Some(action) => + let editor = + Exercise.main_editor_of_state(~selection=pos, model.editors); + let* new_editor = + // Hack[Matt]: put Editor.t into a CodeSelectable.t to use its update function + editor + |> CodeSelectable.Model.mk + |> CodeSelectable.Update.update(~settings, action); + { + ...model, + editors: + Exercise.put_main_editor( + ~selection=pos, + model.editors, + new_editor.editor, ), - exp_ctx_view, - ]), - ]); + }; + | None => Updated.return_quiet(model) + } + | Editor(pos, ResultAction(_) as action) + when + Exercise.visible_in(pos, ~instructor_mode) + || action + |> ( + fun + | ResultAction(UpdateResult(_)) => true + | _ => false + ) => + let cell = Exercise.get_stitched(pos, model.cells); + let* new_cell = CellEditor.Update.update(~settings, action, cell); + {...model, cells: Exercise.put_stitched(pos, model.cells, new_cell)}; + | Editor(_, ResultAction(_)) => Updated.return_quiet(model) // TODO: I think this case should never happen + | ResetEditor(pos) => + let spec = Exercise.main_editor_of_state(~selection=pos, model.spec); + let new_editor = Editor.Model.mk(spec); + { + ...model, + editors: + Exercise.put_main_editor(~selection=pos, model.editors, new_editor), + } + |> Updated.return; + | ResetExercise => + let new_editors = + Exercise.map(model.spec, Editor.Model.mk, Editor.Model.mk); + {...model, editors: new_editors} |> Updated.return; + }; + }; + + let calculate = + (~settings, ~is_edited, ~schedule_action, model: Model.t): Model.t => { + let stitched_elabs = Exercise.stitch_term(model.editors); + let worker_request = ref([]); + let queue_worker = (pos, expr) => { + worker_request := + worker_request^ @ [(pos |> Exercise.key_for_statics, expr)]; + }; + let cells = + Exercise.map2_stitched( + (pos, {term, editor}: Exercise.TermItem.t, cell: CellEditor.Model.t) => + { + editor: { + editor, + statics: cell.editor.statics, + }, + result: cell.result, + } + |> CellEditor.Update.calculate( + ~settings, + ~is_edited, + ~queue_worker=Some(queue_worker(pos)), + ~stitch=_ => + term + ), + stitched_elabs, + model.cells, + ); + WorkerClient.request( + worker_request^, + ~handler= + List.iter(((pos, result)) => { + let pos' = Exercise.pos_of_key(pos); + let result': + Haz3lcore.ProgramResult.t(Haz3lcore.ProgramResult.inner) = + switch (result) { + | Ok((r, s)) => ResultOk({result: r, state: s}) + | Error(e) => ResultFail(e) + }; + schedule_action( + Editor(pos', ResultAction(UpdateResult(result'))), + ); + }), + ~timeout=_ => { + let _ = + Exercise.map_stitched( + (pos, _) => + schedule_action( + Editor( + pos, + ResultAction(UpdateResult(ResultFail(Timeout))), + ), + ), + model.cells, + ); + (); }, ); - let your_tests_view = - Always( - editor_view( - YourTestsValidation, - ~caption="Test Validation", - ~subcaption=": Your Tests vs. Correct Implementation", - ~editor=eds.your_tests.tests, - ~di=test_validation, - ~footer=[ - Grading.TestValidationReport.view( - ~inject, - grading_report.test_validation_report, - grading_report.point_distribution.test_validation, + /* The following section pulls statics back from cells into the editors + There are many ad-hoc things about this code, including the fact that + one of the editors is shown in two cells, so we arbitrarily choose which + statics to take */ + let editors: Exercise.p('a) = { + let calculate = Editor.Update.calculate(~settings, ~is_edited); + { + title: model.editors.title, + version: model.editors.version, + module_name: model.editors.module_name, + prompt: model.editors.prompt, + point_distribution: model.editors.point_distribution, + prelude: + calculate(cells.prelude.editor.statics, model.editors.prelude), + correct_impl: + calculate( + cells.test_validation.editor.statics, + model.editors.correct_impl, ), - ], - ), - ); - let wrong_impl_views = - List.mapi( - (i, (Exercise.{impl, _}, di)) => { - InstructorOnly( - () => - editor_view( - HiddenBugs(i), - ~caption="Wrong Implementation " ++ string_of_int(i + 1), - ~editor=impl, - ~di, + your_tests: { + tests: + calculate( + cells.user_tests.editor.statics, + model.editors.your_tests.tests, ), - ) - }, - List.combine(eds.hidden_bugs, hidden_bugs), - ); - let mutation_testing_view = - Always( - Grading.MutationTestingReport.view( - ~inject, - grading_report.mutation_testing_report, - grading_report.point_distribution.mutation_testing, - ), - ); - let your_impl_view = { - Always( - editor_view( - YourImpl, - ~caption="Your Implementation", - ~editor=eds.your_impl, - ~di=user_impl, - ~footer= - Cell.footer( - ~locked=false, - ~settings, - ~inject, - ~ui_state, - ~result=user_impl.result, - ~result_key=Exercise.user_impl_key, + required: model.editors.your_tests.required, + provided: model.editors.your_tests.provided, + }, + your_impl: + calculate(cells.user_impl.editor.statics, model.editors.your_impl), + hidden_bugs: + List.map2( + (cell: CellEditor.Model.t, editor: Exercise.wrong_impl('a)): + Exercise.wrong_impl('a) => + { + impl: calculate(cell.editor.statics, editor.impl), + hint: editor.hint, + }, + cells.hidden_bugs, + model.editors.hidden_bugs, ), - ), + hidden_tests: { + tests: + calculate( + cells.hidden_tests.editor.statics, + model.editors.hidden_tests.tests, + ), + hints: model.editors.hidden_tests.hints, + }, + syntax_tests: model.editors.syntax_tests, + }; + }; + {spec: model.spec, editors, cells}; + }; +}; + +module Selection = { + open Cursor; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = (Exercise.pos, CellEditor.Selection.t); + + let get_cursor_info = (~selection, model: Model.t): cursor(Update.t) => { + let (pos, s) = selection; + let cell_editor = Exercise.get_stitched(pos, model.cells); + let+ a = CellEditor.Selection.get_cursor_info(~selection=s, cell_editor); + Update.Editor(pos, a); + }; + + let handle_key_event = (~selection, ~event, model: Model.t) => { + let (pos, s) = selection; + let cell_editor = Exercise.get_stitched(pos, model.cells); + CellEditor.Selection.handle_key_event(~selection=s, ~event, cell_editor) + |> Option.map(a => Update.Editor(pos, a)); + }; + + let jump_to_tile = + (~settings: Settings.t, tile, model: Model.t): option((Update.t, t)) => { + Exercise.positioned_editors(model.editors) + |> List.find_opt(((p, e: Editor.t)) => + TileMap.find_opt(tile, e.syntax.tiles) != None + && Exercise.visible_in(p, ~instructor_mode=settings.instructor_mode) + ) + |> Option.map(((pos, _)) => + ( + Update.Editor(pos, MainEditor(Perform(Jump(TileId(tile))))), + (pos, CellEditor.Selection.MainEditor), + ) + ); + }; +}; + +module View = { + type event = + | MakeActive(Selection.t); + + type vis_marked('a) = + | InstructorOnly(unit => 'a) + | Always('a); + + let render_cells = (settings: Settings.t, v: list(vis_marked(Node.t))) => { + List.filter_map( + vis => + switch (vis) { + | InstructorOnly(f) => settings.instructor_mode ? Some(f()) : None + | Always(node) => Some(node) + }, + v, ); }; - let syntax_grading_view = - Always(Grading.SyntaxReport.view(grading_report.syntax_report)); - - let impl_validation_view = - Always( - editor_view( - YourTestsTesting, - ~caption="Implementation Validation", - ~subcaption= - ": Your Tests (synchronized with Test Validation above) vs. Your Implementation", - ~editor=eds.your_tests.tests, - ~di=user_tests, - ~footer=[ - Cell.test_report_footer_view( - ~inject, - ~test_results=ModelResult.test_results(user_tests.result), + + let view = + ( + ~globals: Globals.t, + ~signal: event => 'b, + ~inject: Update.t => 'b, + ~selection: option(Selection.t), + model: Model.t, + ) => { + let eds = model.editors; + let { + test_validation, + user_impl, + user_tests, + prelude, + instructor, + hidden_bugs, + hidden_tests, + }: + Exercise.stitched('a) = + model.cells; + + let stitched_tests = + Exercise.map_stitched( + (_, cell_editor: CellEditor.Model.t) => + cell_editor.result |> EvalResult.Model.make_test_report, + model.cells, + ); + + let grading_report = Grading.GradingReport.mk(eds, ~stitched_tests); + + let score_view = Grading.GradingReport.view_overall_score(grading_report); + + let editor_view = + ( + ~caption: string, + ~subcaption: option(string)=?, + ~result_kind=EvalResult.View.NoResults, + this_pos: Exercise.pos, + cell: CellEditor.Model.t, + ) => { + CellEditor.View.view( + ~globals, + ~signal= + fun + | MakeActive(a) => signal(MakeActive((this_pos, a))), + ~selected= + switch (selection) { + | Some((pos, s)) when pos == this_pos => Some(s) + | _ => None + }, + ~inject=a => inject(Editor(this_pos, a)), + ~result_kind, + ~caption=CellCommon.caption(caption, ~rest=?subcaption), + cell, + ); + }; + + let title_view = CellCommon.title_cell(eds.title); + + let prompt_view = + CellCommon.narrative_cell( + div(~attrs=[Attr.class_("cell-prompt")], [eds.prompt]), + ); + + let prelude_view = + Always( + editor_view( + Prelude, + prelude, + ~subcaption=globals.settings.instructor_mode ? "" : " (Read-Only)", + ~caption="Prelude", + ), + ); + + let correct_impl_view = + InstructorOnly( + () => + editor_view( + CorrectImpl, + instructor, + ~caption="Correct Implementation", ), - ], - ), - ); + ); - let hidden_tests_view = - InstructorOnly( - () => + // determine trailing hole + // TODO: module + let correct_impl_ctx_view = + Always( + { + let exp_ctx_view = { + let correct_impl_trailing_hole_ctx = + Haz3lcore.Editor.Model.trailing_hole_ctx( + eds.correct_impl, + instructor.editor.statics.info_map, + ); + let prelude_trailing_hole_ctx = + Haz3lcore.Editor.Model.trailing_hole_ctx( + eds.prelude, + prelude.editor.statics.info_map, + ); + switch (correct_impl_trailing_hole_ctx, prelude_trailing_hole_ctx) { + | (None, _) => Node.div([text("No context available (1)")]) + | (_, None) => Node.div([text("No context available (2)")]) // TODO show exercise configuration error + | ( + Some(correct_impl_trailing_hole_ctx), + Some(prelude_trailing_hole_ctx), + ) => + let specific_ctx = + Haz3lcore.Ctx.subtract_prefix( + correct_impl_trailing_hole_ctx, + prelude_trailing_hole_ctx, + ); + switch (specific_ctx) { + | None => Node.div([text("No context available")]) // TODO show exercise configuration error + | Some(specific_ctx) => + ContextInspector.ctx_view(~globals, specific_ctx) + }; + }; + }; + CellCommon.simple_cell_view([ + CellCommon.simple_cell_item([ + CellCommon.caption( + "Correct Implementation", + ~rest=" (Type Signatures Only)", + ), + exp_ctx_view, + ]), + ]); + }, + ); + + let your_tests_view = + Always( editor_view( - HiddenTests, - ~caption="Hidden Tests", - ~editor=eds.hidden_tests.tests, - ~di=instructor, + YourTestsValidation, + test_validation, + ~caption="Test Validation", + ~subcaption=": Your Tests vs. Correct Implementation", + ~result_kind= + Custom( + Grading.TestValidationReport.view( + ~signal_jump= + id => + inject( + Editor( + YourTestsValidation, + MainEditor(Perform(Jump(TileId(id)))), + ), + ), + grading_report.test_validation_report, + grading_report.point_distribution.test_validation, + ), + ), ), - ); + ); - let impl_grading_view = - Always( - Grading.ImplGradingReport.view( - ~inject, - ~report=grading_report.impl_grading_report, - ~syntax_report=grading_report.syntax_report, - ~max_points=grading_report.point_distribution.impl_grading, - ), - ); - [score_view, title_view, prompt_view] - @ render_cells( - settings, - [ - prelude_view, - correct_impl_view, - correct_impl_ctx_view, - your_tests_view, - ] - @ wrong_impl_views - @ [ - mutation_testing_view, - your_impl_view, - syntax_grading_view, - impl_validation_view, - hidden_tests_view, - impl_grading_view, - ], - ); -}; + let wrong_impl_views = + List.mapi( + (i, cell) => { + InstructorOnly( + () => + editor_view( + HiddenBugs(i), + cell, + ~caption="Wrong Implementation " ++ string_of_int(i + 1), + ), + ) + }, + hidden_bugs, + ); -let reset_button = inject => - Widgets.button_named( - Icons.trash, - _ => { - let confirmed = - JsUtil.confirm( - "Are you SURE you want to reset this exercise? You will lose any existing code that you have written, and course staff have no way to restore it!", - ); - if (confirmed) { - inject(UpdateAction.ResetCurrentEditor); - } else { - Virtual_dom.Vdom.Effect.Ignore; - }; - }, - ~tooltip="Reset Exercise", - ); - -let instructor_export = (inject: UpdateAction.t => Ui_effect.t(unit)) => - Widgets.button_named( - Icons.export, - _ => inject(Export(ExerciseModule)), - ~tooltip="Export Exercise Module", - ); - -let instructor_transitionary_export = - (inject: UpdateAction.t => Ui_effect.t(unit)) => - Widgets.button_named( - Icons.export, - _ => {inject(Export(TransitionaryExerciseModule))}, - ~tooltip="Export Transitionary Exercise Module", - ); - -let instructor_grading_export = (inject: UpdateAction.t => Ui_effect.t(unit)) => - Widgets.button_named( - Icons.export, - _ => {inject(Export(GradingExerciseModule))}, - ~tooltip="Export Grading Exercise Module", - ); - -let export_submission = (inject: UpdateAction.t => Ui_effect.t(unit)) => - Widgets.button_named( - Icons.star, - _ => inject(Export(Submission)), - ~tooltip="Export Submission", - ); - -let import_submission = (~inject) => - Widgets.file_select_button_named( - "import-submission", - Icons.import, - file => { - switch (file) { - | None => Virtual_dom.Vdom.Effect.Ignore - | Some(file) => inject(UpdateAction.InitImportAll(file)) - } - }, - ~tooltip="Import Submission", - ); + let mutation_testing_view = + Always( + Grading.MutationTestingReport.view( + ~inject, + grading_report.mutation_testing_report, + grading_report.point_distribution.mutation_testing, + ), + ); + + let your_impl_view = { + Always( + editor_view( + YourImpl, + user_impl, + ~caption="Your Implementation", + ~result_kind=EvalResults, + ), + ); + }; + + let syntax_grading_view = + Always(Grading.SyntaxReport.view(grading_report.syntax_report)); + + let impl_validation_view = + Always( + editor_view( + YourTestsTesting, + user_tests, + ~caption="Implementation Validation", + ~subcaption= + ": Your Tests (code synchronized with Test Validation cell above) vs. Your Implementation", + ~result_kind=TestResults, + ), + ); + + let hidden_tests_view = + InstructorOnly( + () => editor_view(HiddenTests, hidden_tests, ~caption="Hidden Tests"), + ); + + let impl_grading_view = + Always( + Grading.ImplGradingReport.view( + ~signal_jump= + id => + inject( + Editor( + YourTestsTesting, + MainEditor(Perform(Jump(TileId(id)))), + ), + ), + ~report=grading_report.impl_grading_report, + ~syntax_report=grading_report.syntax_report, + ~max_points=grading_report.point_distribution.impl_grading, + ), + ); + + [score_view, title_view, prompt_view] + @ render_cells( + globals.settings, + [ + prelude_view, + correct_impl_view, + correct_impl_ctx_view, + your_tests_view, + ] + @ wrong_impl_views + @ [ + mutation_testing_view, + your_impl_view, + syntax_grading_view, + impl_validation_view, + hidden_tests_view, + impl_grading_view, + ], + ); + }; +}; diff --git a/src/haz3lweb/view/FontSpecimen.re b/src/haz3lweb/view/FontSpecimen.re index f5a5e6ab38..214d4cd24b 100644 --- a/src/haz3lweb/view/FontSpecimen.re +++ b/src/haz3lweb/view/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/view/Kind.re b/src/haz3lweb/view/Kind.re index 8feb3af0b0..0eee9db324 100644 --- a/src/haz3lweb/view/Kind.re +++ b/src/haz3lweb/view/Kind.re @@ -2,8 +2,25 @@ open Virtual_dom.Vdom; open Node; open Util.Web; -let view = (kind: Haz3lcore.Ctx.kind): Node.t => +let view = (~globals, kind: Haz3lcore.Ctx.kind): Node.t => switch (kind) { - | Singleton(ty) => div_c("kind-view", [Type.view(ty)]) + | Singleton(ty) => + div_c( + "kind-view", + [ + CodeViewable.view_typ( + ~globals, + ~settings={ + inline: true, + fold_case_clauses: false, + fold_fn_bodies: false, + hide_fixpoints: false, + fold_cast_types: false, + }, + ~info_map=Haz3lcore.Id.Map.empty, + ty, + ), + ], + ) | Abstract => div_c("kind-view", [text("Type")]) }; diff --git a/src/haz3lweb/view/NutMenu.re b/src/haz3lweb/view/NutMenu.re index b67f406504..2155d0f26f 100644 --- a/src/haz3lweb/view/NutMenu.re +++ b/src/haz3lweb/view/NutMenu.re @@ -1,14 +1,34 @@ -open Util; open Virtual_dom.Vdom; -open Js_of_ocaml; open Node; open Util.Web; open Widgets; open Haz3lcore; -let settings_group = (~inject, name: string, ts) => { +// COMPONENTS + +let item_group = (~inject as _, name: string, ts) => { + div_c("group", [div_c("name", [text(name)]), div_c("contents", ts)]); +}; + +let submenu = (~tooltip, ~icon, menu) => + div( + ~attrs=[clss(["top-menu-item"])], + [ + div( + ~attrs=[clss(["submenu-icon"]), Attr.title(tooltip)], + [div(~attrs=[clss(["icon"])], [icon])], + ), + div(~attrs=[clss(["submenu"])], menu), + ], + ); + +// SETTINGS MENU + +let settings_group = (~globals: Globals.t, name: string, ts) => { let toggle = ((_icon, tooltip, bool, setting)) => - toggle_named("", ~tooltip, bool, _ => inject(UpdateAction.Set(setting))); + toggle_named("", ~tooltip, bool, _ => + globals.inject_global(Set(setting)) + ); div_c( "group", [ @@ -18,15 +38,20 @@ let settings_group = (~inject, name: string, ts) => { ); }; -let semantics_group = (~inject, ~settings: Settings.t) => { +let semantics_group = (~globals) => { settings_group( - ~inject, + ~globals, "Semantics", [ - ("τ", "Types", settings.core.statics, Statics), - ("⇲", "Completion", settings.core.assist, Assist), - ("𝛿", "Evaluation", settings.core.dynamics, Dynamics), - ("?", "Docs", settings.explainThis.show, ExplainThis(ToggleShow)), + ("τ", "Types", globals.settings.core.statics, Statics), + ("⇲", "Completion", globals.settings.core.assist, Assist), + ("𝛿", "Evaluation", globals.settings.core.dynamics, Dynamics), + ( + "?", + "Docs", + globals.settings.explainThis.show, + ExplainThis(ToggleShow), + ), // ( // "👍", // "Feedback", @@ -37,10 +62,10 @@ let semantics_group = (~inject, ~settings: Settings.t) => { ); }; -let values_group = (~inject, ~settings: Settings.t) => { - let s = settings.core.evaluation; +let values_group = (~globals: Globals.t) => { + let s = globals.settings.core.evaluation; settings_group( - ~inject, + ~globals, "Value Display", [ ("λ", "Functions", s.show_fn_bodies, Evaluation(ShowFnBodies)), @@ -51,10 +76,10 @@ let values_group = (~inject, ~settings: Settings.t) => { ); }; -let stepper_group = (~inject, ~settings: Settings.t) => { - let s = settings.core.evaluation; +let stepper_group = (~globals: Globals.t) => { + let s = globals.settings.core.evaluation; settings_group( - ~inject, + ~globals, "Stepper", [ ("🔍", "Show lookups", s.show_lookup_steps, Evaluation(ShowLookups)), @@ -69,169 +94,23 @@ let stepper_group = (~inject, ~settings: Settings.t) => { ); }; -let dev_group = (~inject, ~settings: Settings.t) => { +let dev_group = (~globals) => { settings_group( - ~inject, + ~globals, "Developer", [ - ("✓", "Benchmarks", settings.benchmark, Benchmark), - ("𝑒", "Elaboration", settings.core.elaborate, Elaborate), - ("↵", "Whitespace", settings.secondary_icons, SecondaryIcons), + ("✓", "Benchmarks", globals.settings.benchmark, Benchmark), + ("𝑒", "Elaboration", globals.settings.core.elaborate, Elaborate), + ("↵", "Whitespace", globals.settings.secondary_icons, SecondaryIcons), ], ); }; -let settings_menu = (~inject, ~settings: Settings.t) => { +let settings_menu = (~globals) => { [ - semantics_group(~inject, ~settings), - values_group(~inject, ~settings), - stepper_group(~inject, ~settings), - dev_group(~inject, ~settings), + semantics_group(~globals), + values_group(~globals), + stepper_group(~globals), + dev_group(~globals), ]; }; - -let export_persistent_data = (~inject: Update.t => 'a) => - button_named( - Icons.export, - _ => inject(Export(ExportPersistentData)), - ~tooltip="Export All Persistent Data", - ); - -let reset_hazel = - button_named( - Icons.bomb, - _ => { - let confirmed = - JsUtil.confirm( - "Are you SURE you want to reset Hazel to its initial state? You will lose any existing code that you have written, and course staff have no way to restore it!", - ); - if (confirmed) { - JsUtil.clear_localstore(); - Dom_html.window##.location##reload; - }; - Virtual_dom.Vdom.Effect.Ignore; - }, - ~tooltip="Reset Hazel (LOSE ALL DATA)", - ); - -let reparse = (~inject: Update.t => 'a) => - button_named( - Icons.backpack, - _ => inject(PerformAction(Reparse)), - ~tooltip="Reparse Editor", - ); - -let item_group = (~inject as _, name: string, ts) => { - div_c("group", [div_c("name", [text(name)]), div_c("contents", ts)]); -}; - -let file_group_scratch = (~inject) => - item_group( - ~inject, - "File", - [ScratchMode.export_button(inject), ScratchMode.import_button(inject)], - ); - -let reset_group_scratch = (~inject) => - item_group( - ~inject, - "Reset", - [ScratchMode.reset_button(inject), reparse(~inject), reset_hazel], - ); - -let file_group_exercises = (~inject) => - item_group( - ~inject, - "File", - [ - ExerciseMode.export_submission(inject), - ExerciseMode.import_submission(~inject), - ], - ); - -let reset_group_exercises = (~inject) => - item_group( - ~inject, - "Reset", - [ExerciseMode.reset_button(inject), reparse(~inject), reset_hazel], - ); - -let dev_group_exercises = (~inject) => - item_group( - ~inject, - "Developer Export", - [ - export_persistent_data(~inject), - ExerciseMode.instructor_export(inject), - ExerciseMode.instructor_transitionary_export(inject), - ExerciseMode.instructor_grading_export(inject), - ], - ); - -let file_menu = (~inject, ~settings: Settings.t, editors: Editors.t) => - switch (editors) { - | Scratch(_) => [ - file_group_scratch(~inject), - reset_group_scratch(~inject), - ] - | Documentation(_) => [ - file_group_scratch(~inject), - reset_group_scratch(~inject), - ] - | Exercises(_) when settings.instructor_mode => [ - file_group_exercises(~inject), - reset_group_exercises(~inject), - dev_group_exercises(~inject), - ] - | Exercises(_) => [ - file_group_exercises(~inject), - reset_group_exercises(~inject), - ] - }; - -let submenu = (~tooltip, ~icon, menu) => - div( - ~attrs=[clss(["top-menu-item"])], - [ - div( - ~attrs=[clss(["submenu-icon"]), Attr.title(tooltip)], - [div(~attrs=[clss(["icon"])], [icon])], - ), - div(~attrs=[clss(["submenu"])], menu), - ], - ); - -let view = - (~inject: Update.t => 'a, ~settings: Settings.t, ~editors: Editors.t) => - div( - ~attrs=[clss(["nut-menu"])], - [ - submenu( - ~tooltip="Settings", - ~icon=Icons.gear, - settings_menu(~inject, ~settings), - ), - submenu( - ~tooltip="File", - ~icon=Icons.disk, - file_menu(~inject, ~settings, editors), - ), - button( - Icons.command_palette_sparkle, - _ => { - NinjaKeys.open_command_palette(); - Effect.Ignore; - }, - ~tooltip= - "Command Palette (" - ++ Keyboard.meta(Os.is_mac^ ? Mac : PC) - ++ " + k)", - ), - link( - Icons.github, - "https://github.com/hazelgrove/hazel", - ~tooltip="Hazel on GitHub", - ), - link(Icons.info, "https://hazel.org", ~tooltip="Hazel Homepage"), - ], - ); diff --git a/src/haz3lweb/view/Page.re b/src/haz3lweb/view/Page.re index df98ba5ee9..a55487c0fe 100644 --- a/src/haz3lweb/view/Page.re +++ b/src/haz3lweb/view/Page.re @@ -1,198 +1,512 @@ -open Util; -open Web; open Js_of_ocaml; -open Haz3lcore; open Virtual_dom.Vdom; open Node; +open Util; + +/* The top-level UI component of Hazel */ + +/* This file follows conventions in [docs/ui-architecture.md] */ -let key_handler = - ( - ~inject: UpdateAction.t => Ui_effect.t(unit), - ~dir: Key.dir, - editor: Editor.t, - evt: Js.t(Dom_html.keyboardEvent), - ) - : Effect.t(unit) => { - open Effect; - let key = Key.mk(dir, evt); - switch (ProjectorView.key_handoff(editor, key)) { - | Some(action) => - Many([Prevent_default, inject(PerformAction(Project(action)))]) - | None => - switch (Keyboard.handle_key_event(key)) { - | None => Ignore - | Some(action) => Many([Prevent_default, inject(action)]) - } +[@deriving (show({with_path: false}), sexp, yojson)] +type selection = Editors.Selection.t; + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + globals: Globals.Model.t, + editors: Editors.Model.t, + explain_this: ExplainThisModel.t, + selection, }; + + let equal = (===); }; -let handlers = - (~inject: UpdateAction.t => Ui_effect.t(unit), editor: Editor.t) => { - [ - Attr.on_keyup(key_handler(~inject, editor, ~dir=KeyUp)), - Attr.on_keydown(key_handler(~inject, editor, ~dir=KeyDown)), - /* safety handler in case mousedown overlay doesn't catch it */ - Attr.on_mouseup(_ => inject(SetMeta(Mouseup))), - Attr.on_blur(_ => { - JsUtil.focus_clipboard_shim(); - Effect.Ignore; - }), - Attr.on_focus(_ => { - JsUtil.focus_clipboard_shim(); - Effect.Ignore; - }), - Attr.on_copy(_ => { - JsUtil.copy(Printer.to_string_selection(editor)); - Effect.Ignore; - }), - Attr.on_cut(_ => { - JsUtil.copy(Printer.to_string_selection(editor)); - inject(UpdateAction.PerformAction(Destruct(Left))); - }), - Attr.on_paste(evt => { - let pasted_text = - Js.to_string(evt##.clipboardData##getData(Js.string("text"))) - |> Util.StringUtil.trim_leading; - Dom.preventDefault(evt); - inject(PerformAction(Paste(pasted_text))); - }), - ]; +module Store = { + let load = (): Model.t => { + let globals = Globals.Model.load(); + let editors = + Editors.Store.load( + ~settings=globals.settings.core, + ~instructor_mode=globals.settings.instructor_mode, + ); + let explain_this = ExplainThisModel.Store.load(); + { + editors, + globals, + explain_this, + selection: Editors.Selection.default_selection(editors), + }; + }; + + let save = (m: Model.t): unit => { + Editors.Store.save( + ~instructor_mode=m.globals.settings.instructor_mode, + m.editors, + ); + Globals.Model.save(m.globals); + ExplainThisModel.Store.save(m.explain_this); + }; }; -let top_bar = - ( - ~inject: UpdateAction.t => Ui_effect.t(unit), - ~settings: Settings.t, - ~editors, - ) => - div( - ~attrs=[Attr.id("top-bar")], - [ - div( - ~attrs=[Attr.class_("wrap")], - [a(~attrs=[clss(["nut-icon"])], [Icons.hazelnut])], - ), - NutMenu.view(~inject, ~settings, ~editors), - div( - ~attrs=[Attr.class_("wrap")], - [div(~attrs=[Attr.id("title")], [text("hazel")])], - ), - div( - ~attrs=[Attr.class_("wrap")], - [EditorModeView.view(~inject, ~settings, ~editors)], - ), - ], - ); - -let main_view = - ( - ~inject: UpdateAction.t => Ui_effect.t(unit), - {settings, editors, explainThisModel, results, ui_state, _}: Model.t, - ) => { - let editor = Editors.get_editor(editors); - let cursor_info = - Indicated.ci_of(editor.state.zipper, editor.state.meta.statics.info_map); - let highlights = - ExplainThis.get_color_map(~settings, ~explainThisModel, cursor_info); - let (editors_view, cursor_info) = - switch (editors) { - | Scratch(idx, _) => - let result_key = ScratchSlide.scratch_key(string_of_int(idx)); - let view = - ScratchMode.view( - ~inject, - ~ui_state, - ~settings, - ~highlights, - ~results, - ~result_key, - editor, +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type benchmark_action = + | Start + | Finish; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Globals(Globals.Update.t) + | Editors(Editors.Update.t) + | ExplainThis(ExplainThisUpdate.update) + | MakeActive(selection) + | Benchmark(benchmark_action) + | Start + | Save; + + let update_global = + ( + ~import_log, + ~schedule_action, + ~globals: Globals.Model.t, + action: Globals.Update.t, + model: Model.t, + ) => { + switch (action) { + | SetMousedown(mousedown) => + { + ...model, + globals: { + ...model.globals, + mousedown, + }, + } + |> Updated.return_quiet + | SetShowBackpackTargets(show) => + { + ...model, + globals: { + ...model.globals, + show_backpack_targets: show, + }, + } + |> Updated.return_quiet + | SetFontMetrics(fm) => + { + ...model, + globals: { + ...model.globals, + font_metrics: fm, + }, + } + |> Updated.return_quiet(~scroll_active=true) + | Set(settings) => + let* settings = + Settings.Update.update(settings, model.globals.settings); + { + ...model, + globals: { + ...model.globals, + settings, + }, + }; + | JumpToTile(tile) => + let jump = + Editors.Selection.jump_to_tile( + ~settings=model.globals.settings, + tile, + model.editors, ); - (view, cursor_info); - | Documentation(name, _) => - let result_key = ScratchSlide.scratch_key(name); - let view = - ScratchMode.view( - ~inject, - ~ui_state, - ~settings, - ~highlights, - ~results, - ~result_key, - editor, + switch (jump) { + | None => model |> Updated.return_quiet + | Some((action, selection)) => + let* editors = + Editors.Update.update( + ~globals, + ~schedule_action=a => schedule_action(Editors(a)), + action, + model.editors, + ); + {...model, editors, selection}; + }; + | InitImportAll(file) => + JsUtil.read_file(file, data => + schedule_action(Globals(FinishImportAll(data))) + ); + model |> return_quiet; + | FinishImportAll(None) => model |> return_quiet + | FinishImportAll(Some(data)) => + Export.import_all(~import_log, data, ~specs=ExerciseSettings.exercises); + Store.load() |> return; + | ExportPersistentData => + Store.save(model); + Export.export_persistent(); + model |> return_quiet; + | ActiveEditor(action) => + let cursor_info = + Editors.Selection.get_cursor_info( + ~selection=model.selection, + model.editors, ); - let info = - SlideContent.get_content(editors) - |> Option.map(i => div(~attrs=[Attr.id("slide")], [i])) - |> Option.to_list; - (info @ view, cursor_info); - | Exercises(_, _, exercise) => - /* Note the exercises mode uses a seperate path to calculate - * statics and dynamics via stitching together multiple editors */ - let stitched_dynamics = - Exercise.stitch_dynamic( - settings.core, - exercise, - settings.core.dynamics ? Some(results) : None, + switch (cursor_info.editor_action(action)) { + | None => model |> return_quiet + | Some(action) => + let* editors = + Editors.Update.update( + ~globals=model.globals, + ~schedule_action=a => schedule_action(Editors(a)), + action, + model.editors, + ); + {...model, editors}; + }; + | Undo => + let cursor_info = + Editors.Selection.get_cursor_info( + ~selection=model.selection, + model.editors, ); - let statics = - Exercise.statics_of_stiched_dynamics(exercise, stitched_dynamics); + switch (cursor_info.undo_action) { + | None => model |> return_quiet + | Some(action) => + let* editors = + Editors.Update.update( + ~globals=model.globals, + ~schedule_action=a => schedule_action(Editors(a)), + action, + model.editors, + ); + {...model, editors}; + }; + | Redo => let cursor_info = - Indicated.ci_of(editor.state.zipper, statics.info_map); - let highlights = - ExplainThis.get_color_map(~settings, ~explainThisModel, cursor_info); - let view = - ExerciseMode.view( - ~inject, - ~ui_state, - ~settings, - ~highlights, - ~stitched_dynamics, - ~exercise, + Editors.Selection.get_cursor_info( + ~selection=model.selection, + model.editors, ); - (view, cursor_info); + switch (cursor_info.redo_action) { + | None => model |> return_quiet + | Some(action) => + let* editors = + Editors.Update.update( + ~globals=model.globals, + ~schedule_action=a => schedule_action(Editors(a)), + action, + model.editors, + ); + {...model, editors}; + }; }; + }; - let bottom_bar = - CursorInspector.view(~inject, ~settings, editor, cursor_info); - let sidebar = - settings.explainThis.show && settings.core.statics - ? ExplainThis.view( - ~inject, - ~ui_state, - ~settings, - ~explainThisModel, - cursor_info, - ) - : div([]); - [ - top_bar(~inject, ~settings, ~editors), - div( - ~attrs=[ - Attr.id("main"), - Attr.classes([Settings.show_mode(settings.mode)]), - ], - editors_view, - ), - sidebar, - bottom_bar, - ContextInspector.view(~inject, ~settings, cursor_info), - ]; + let update = + ( + ~import_log, + ~get_log_and, + ~schedule_action: t => unit, + action: t, + model: Model.t, + ) => { + let globals = { + ...model.globals, + export_all: Export.export_all, + get_log_and, + }; + switch (action) { + | Globals(action) => + update_global(~globals, ~import_log, ~schedule_action, action, model) + | Editors(action) => + let* editors = + Editors.Update.update( + ~globals, + ~schedule_action=a => schedule_action(Editors(a)), + action, + model.editors, + ); + {...model, editors}; + | ExplainThis(action) => + let* explain_this = + ExplainThisUpdate.set_update(model.explain_this, action); + {...model, explain_this}; + | MakeActive(selection) => {...model, selection} |> Updated.return + | Benchmark(Start) => + List.iter(a => schedule_action(Editors(a)), Benchmark.actions_1); + schedule_action(Benchmark(Finish)); + Benchmark.start(); + model |> Updated.return_quiet; + | Benchmark(Finish) => + Benchmark.finish(); + model |> Updated.return_quiet; + | Start => model |> return // Triggers recalculation at the start + | Save => + print_endline("Saving..."); + Store.save(model); + model |> return_quiet; + }; + }; + + let calculate = (~schedule_action, ~is_edited, model: Model.t) => { + let editors = + Editors.Update.calculate( + ~settings=model.globals.settings.core, + ~schedule_action=a => schedule_action(Editors(a)), + ~is_edited, + model.editors, + ); + let cursor_info = + Editors.Selection.get_cursor_info( + ~selection=model.selection, + model.editors, + ); + let color_highlights = + ExplainThis.get_color_map( + ~globals=model.globals, + ~explainThisModel=model.explain_this, + cursor_info.info, + ); + let globals = Globals.Update.calculate(color_highlights, model.globals); + {...model, globals, editors}; + }; }; -let get_selection = (model: Model.t): string => - model.editors |> Editors.get_editor |> Printer.to_string_selection; +module Selection = { + open Cursor; + + type t = selection; + + let handle_key_event = + (~selection, ~event: Key.t, model: Model.t): option(Update.t) => { + switch (event) { + | {key: D("Alt"), sys: Mac | PC, shift: Up, meta: Up, ctrl: Up, alt: Down} => + Some(Update.Globals(SetShowBackpackTargets(true))) + | {key: U("Alt"), _} => + Some(Update.Globals(SetShowBackpackTargets(false))) + | {key: D("F7"), sys: Mac | PC, shift: Down, meta: Up, ctrl: Up, alt: Up} => + Some(Update.Benchmark(Start)) + | _ => + Editors.Selection.handle_key_event(~selection, ~event, model.editors) + |> Option.map(x => Update.Editors(x)) + }; + }; -let view = (~inject: UpdateAction.t => Ui_effect.t(unit), model: Model.t) => - div( - ~attrs=[ - Attr.id("page"), - ...handlers(~inject, Editors.get_editor(model.editors)), - ], + let get_cursor_info = + (~selection: t, model: Model.t): cursor(Editors.Update.t) => { + Editors.Selection.get_cursor_info(~selection, model.editors); + }; +}; + +module View = { + let handlers = + ( + ~inject: Update.t => Ui_effect.t(unit), + ~cursor: Cursor.cursor(Editors.Update.t), + model: Model.t, + ) => { + let key_handler = + (~inject, ~dir: Key.dir, evt: Js.t(Dom_html.keyboardEvent)) + : Effect.t(unit) => + Effect.( + switch ( + Selection.handle_key_event( + ~selection=Some(model.selection), + ~event=Key.mk(dir, evt), + model, + ) + ) { + | None => Ignore + | Some(action) => + Many([Prevent_default, Stop_propagation, inject(action)]) + } + ); [ - FontSpecimen.view("font-specimen"), - DecUtil.filters, - JsUtil.clipboard_shim, + Attr.on_keyup(key_handler(~inject, ~dir=KeyUp)), + Attr.on_keydown(key_handler(~inject, ~dir=KeyDown)), + /* safety handler in case mousedown overlay doesn't catch it */ + Attr.on_mouseup(_ => inject(Globals(SetMousedown(false)))), + Attr.on_blur(_ => { + JsUtil.focus_clipboard_shim(); + Effect.Ignore; + }), + Attr.on_focus(_ => { + JsUtil.focus_clipboard_shim(); + Effect.Ignore; + }), + Attr.on_copy(_ => { + JsUtil.copy( + (cursor.selected_text |> Option.value(~default=() => ""))(), + ); + Effect.Ignore; + }), + Attr.on_cut(_ => { + JsUtil.copy( + (cursor.selected_text |> Option.value(~default=() => ""))(), + ); + Option.map( + inject, + Selection.handle_key_event( + ~selection=Some(model.selection), + ~event= + Key.{ + key: D("Delete"), + sys: Os.is_mac^ ? Mac : PC, + shift: Up, + meta: Up, + ctrl: Up, + alt: Up, + }, + model, + ), + ) + |> Option.value(~default=Effect.Ignore); + }), ] - @ main_view(~inject, model), - ); + @ [ + Attr.on_paste(evt => { + let pasted_text = + Js.to_string(evt##.clipboardData##getData(Js.string("text"))) + |> Str.global_replace(Str.regexp("\n[ ]*"), "\n"); + Dom.preventDefault(evt); + switch (cursor.editor_action(Paste(pasted_text))) { + | None => Effect.Ignore + | Some(action) => inject(Editors(action)) + }; + }), + ]; + }; + + let nut_menu = + ( + ~globals: Globals.t, + ~inject: Editors.Update.t => 'a, + ~editors: Editors.Model.t, + ) => { + NutMenu.( + Widgets.( + div( + ~attrs=[Attr.class_("nut-menu")], + [ + submenu( + ~tooltip="Settings", + ~icon=Icons.gear, + NutMenu.settings_menu(~globals), + ), + submenu( + ~tooltip="File", + ~icon=Icons.disk, + Editors.View.file_menu(~globals, ~inject, editors), + ), + button( + Icons.command_palette_sparkle, + _ => { + NinjaKeys.open_command_palette(); + Effect.Ignore; + }, + ~tooltip= + "Command Palette (" + ++ Keyboard.meta(Os.is_mac^ ? Mac : PC) + ++ " + k)", + ), + link( + Icons.github, + "https://github.com/hazelgrove/hazel", + ~tooltip="Hazel on GitHub", + ), + link(Icons.info, "https://hazel.org", ~tooltip="Hazel Homepage"), + ], + ) + ) + ); + }; + + let top_bar = (~globals, ~inject: Update.t => Ui_effect.t(unit), ~editors) => + div( + ~attrs=[Attr.id("top-bar")], + [ + div( + ~attrs=[Attr.class_("wrap")], + [a(~attrs=[Attr.class_("nut-icon")], [Icons.hazelnut])], + ), + nut_menu(~globals, ~inject=a => inject(Editors(a)), ~editors), + div( + ~attrs=[Attr.class_("wrap")], + [div(~attrs=[Attr.id("title")], [text("hazel")])], + ), + div( + ~attrs=[Attr.class_("wrap")], + [ + Editors.View.top_bar( + ~globals, + ~inject=a => inject(Editors(a)), + ~editors, + ), + ], + ), + ], + ); + + let main_view = + ( + ~get_log_and: (string => unit) => unit, + ~inject: Update.t => Ui_effect.t(unit), + ~cursor: Cursor.cursor(Editors.Update.t), + {globals, editors, explain_this: explainThisModel, selection} as model: Model.t, + ) => { + let globals = { + ...globals, + inject_global: x => inject(Globals(x)), + get_log_and, + export_all: Export.export_all, + }; + let bottom_bar = + CursorInspector.view( + ~globals, + ~inject=a => inject(Editors(a)), + cursor, + ); + let sidebar = + globals.settings.explainThis.show && globals.settings.core.statics + ? ExplainThis.view( + ~globals, + ~inject=a => inject(ExplainThis(a)), + ~explainThisModel, + cursor.info, + ) + : div([]); + let editors_view = + Editors.View.view( + ~globals, + ~signal= + fun + | MakeActive(selection) => inject(MakeActive(selection)), + ~inject=a => inject(Editors(a)), + ~selection=Some(selection), + model.editors, + ); + [ + top_bar(~globals, ~inject, ~editors), + div( + ~attrs=[ + Attr.id("main"), + Attr.class_(Editors.Model.mode_string(editors)), + ], + editors_view, + ), + sidebar, + bottom_bar, + ContextInspector.view(~globals, cursor.info), + ]; + }; + + let view = + (~get_log_and, ~inject: Update.t => Ui_effect.t(unit), model: Model.t) => { + let cursor = Selection.get_cursor_info(~selection=model.selection, model); + div( + ~attrs=[Attr.id("page"), ...handlers(~cursor, ~inject, model)], + [FontSpecimen.view, DecUtil.filters, JsUtil.clipboard_shim] + @ main_view(~get_log_and, ~cursor, ~inject, model), + ); + }; +}; diff --git a/src/haz3lweb/view/ScratchMode.re b/src/haz3lweb/view/ScratchMode.re index 7fdc8eb361..39b1ee511a 100644 --- a/src/haz3lweb/view/ScratchMode.re +++ b/src/haz3lweb/view/ScratchMode.re @@ -1,81 +1,377 @@ -open Util; open Haz3lcore; +open Util; -type state = (Id.t, Editor.t); +/* This file follows conventions in [docs/ui-architecture.md] */ -let view = - ( - ~inject, - ~ui_state: Model.ui_state, - ~settings: Settings.t, - ~highlights, - ~results: ModelResults.t, - ~result_key, - editor: Editor.t, - ) => { - let result = ModelResults.lookup(results, result_key); - let test_results = Util.OptUtil.and_then(ModelResult.test_results, result); - let target_id = "code-container"; - let footer = - settings.core.elaborate || settings.core.dynamics - ? result - |> Option.map(result => - Cell.footer( - ~locked=false, - ~settings, - ~inject, - ~ui_state, - ~result, - ~result_key, - ) - ) - : None; - [ - Cell.editor_view( - ~inject, - ~ui_state, - ~settings, - ~target_id, - ~test_results, - ~footer?, - ~highlights, - editor, - ), - ]; -}; +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + current: int, + scratchpads: list((string, CellEditor.Model.t)), + }; -let export_button = (inject: Update.t => Ui_effect.t(unit)) => - Widgets.button_named( - Icons.export, - _ => inject(Export(ExportScratchSlide)), - ~tooltip="Export Scratchpad", + let get_spliced_elabs = model => { + let (key, ed) = List.nth(model.scratchpads, model.current); + [(key, Elaborator.Elaboration.{d: ed.editor.statics.term})]; + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type persistent = (int, list((string, CellEditor.Model.persistent))); + + let persist = model => ( + model.current, + List.map(((_, m)) => CellEditor.Model.persist(m), model.scratchpads), ); -let import_button = inject => - Widgets.file_select_button_named( - "import-scratchpad", - Icons.import, - file => { - switch (file) { - | None => Virtual_dom.Vdom.Effect.Ignore - | Some(file) => inject(UpdateAction.InitImportScratchpad(file)) - } - }, - ~tooltip="Import Scratchpad", + + let unpersist = (~settings, (current, slides)) => { + current, + scratchpads: + List.mapi( + (i, m) => + (string_of_int(i), CellEditor.Model.unpersist(~settings, m)), + slides, + ), + }; + + let persist_documentation = model => ( + model.current, + List.map( + ((s, m)) => (s, CellEditor.Model.persist(m)), + model.scratchpads, + ), ); -let reset_button = inject => - Widgets.button_named( - Icons.trash, - _ => { - let confirmed = - JsUtil.confirm( - "Are you SURE you want to reset this scratchpad? You will lose any existing code.", - ); - if (confirmed) { - inject(UpdateAction.ResetCurrentEditor); - } else { - Virtual_dom.Vdom.Effect.Ignore; + let unpersist_documentation = (~settings, (current, slides)) => { + current, + scratchpads: + List.map( + ((s, m)) => (s, CellEditor.Model.unpersist(~settings, m)), + slides, + ), + }; +}; + +module StoreDocumentation = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = Model.persistent; + let key = Store.Documentation; + let default = () => Init.startup.documentation; + }); + +module Store = + Store.F({ + [@deriving (show({with_path: false}), sexp, yojson)] + type t = (int, list(CellEditor.Model.persistent)); + let key = Store.Scratch; + let default = () => Init.startup.scratch; + }); + +module Update = { + open Updated; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | CellAction(CellEditor.Update.t) + | SwitchSlide(int) + | ResetCurrent + | InitImportScratchpad([@opaque] Js_of_ocaml.Js.t(Js_of_ocaml.File.file)) + | FinishImportScratchpad(option(string)) + | Export; + + let export_scratch_slide = (model: Model.t): unit => { + Store.save(model |> Model.persist); + let data = Store.export(); + JsUtil.download_string_file( + ~filename="hazel-scratchpad", + ~content_type="text/plain", + ~contents=data, + ); + }; + + let update = + ( + ~schedule_action, + ~settings: Settings.t, + ~is_documentation: bool, + action, + model: Model.t, + ) => { + switch (action) { + | CellAction(a) => + let (key, ed) = List.nth(model.scratchpads, model.current); + let* new_ed = CellEditor.Update.update(~settings, a, ed); + let new_sp = + ListUtil.put_nth(model.current, (key, new_ed), model.scratchpads); + {...model, scratchpads: new_sp}; + | SwitchSlide(i) => + let* current = i |> Updated.return; + {...model, current}; + | ResetCurrent => + let (key, _) = List.nth(model.scratchpads, model.current); + let source = + switch (is_documentation) { + | false => Init.startup.scratch |> snd + | true => Init.startup.documentation |> snd |> List.map(snd) + }; + let* data = + List.nth(source, model.current) + |> PersistentZipper.unpersist + |> Editor.Model.mk + |> CellEditor.Model.mk + |> Updated.return; + { + ...model, + scratchpads: + ListUtil.put_nth(model.current, (key, data), model.scratchpads), }; - }, - ~tooltip="Reset Editor", - ); + | InitImportScratchpad(file) => + JsUtil.read_file(file, data => + schedule_action(FinishImportScratchpad(data)) + ); + model |> return_quiet; + | FinishImportScratchpad(None) => model |> return_quiet + | FinishImportScratchpad(Some(data)) => + let key = List.nth(model.scratchpads, model.current) |> fst; + let new_data = + data + |> Sexplib.Sexp.of_string + |> CellEditor.Model.persistent_of_sexp + |> CellEditor.Model.unpersist(~settings=settings.core); + + let scratchpads = + ListUtil.put_nth(model.current, (key, new_data), model.scratchpads); + {...model, scratchpads} |> Updated.return; + | Export => + export_scratch_slide(model); + model |> Updated.return_quiet; + }; + }; + + let calculate = + (~settings, ~schedule_action, ~is_edited, model: Model.t): Model.t => { + let (key, ed) = List.nth(model.scratchpads, model.current); + let worker_request = ref([]); + let queue_worker = + Some(expr => {worker_request := worker_request^ @ [("", expr)]}); + let new_ed = + CellEditor.Update.calculate( + ~settings, + ~is_edited, + ~queue_worker, + ~stitch=x => x, + ed, + ); + switch (worker_request^) { + | [] => () + | _ => + WorkerClient.request( + worker_request^, + ~handler= + r => + schedule_action( + CellAction( + ResultAction( + UpdateResult( + switch (r |> List.hd |> snd) { + | Ok((r, s)) => + Haz3lcore.ProgramResult.ResultOk({result: r, state: s}) + | Error(e) => Haz3lcore.ProgramResult.ResultFail(e) + }, + ), + ), + ), + ), + ~timeout= + _ => + schedule_action( + CellAction(ResultAction(UpdateResult(ResultFail(Timeout)))), + ), + ) + }; + let new_sp = + ListUtil.put_nth(model.current, (key, new_ed), model.scratchpads); + {...model, scratchpads: new_sp}; + }; +}; + +module Selection = { + open Cursor; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = CellEditor.Selection.t; + + let get_cursor_info = (~selection, model: Model.t): cursor(Update.t) => { + let+ ci = + CellEditor.Selection.get_cursor_info( + ~selection, + List.nth(model.scratchpads, model.current) |> snd, + ); + Update.CellAction(ci); + }; + + let handle_key_event = + (~selection, ~event: Key.t, model: Model.t): option(Update.t) => + switch (event) { + | {key: D(key), sys: Mac | PC, shift: Up, meta: Down, ctrl: Up, alt: Up} + when Keyboard.is_digit(key) => + Some(Update.SwitchSlide(int_of_string(key))) + | _ => + CellEditor.Selection.handle_key_event( + ~selection, + ~event, + List.nth(model.scratchpads, model.current) |> snd, + ) + |> Option.map(x => Update.CellAction(x)) + }; + + let jump_to_tile = (tile, model: Model.t): option((Update.t, t)) => + CellEditor.Selection.jump_to_tile( + tile, + List.nth(model.scratchpads, model.current) |> snd, + ) + |> Option.map(((x, y)) => (Update.CellAction(x), y)); +}; + +module View = { + type event = + | MakeActive(CellEditor.Selection.t); + + let view = + ( + ~globals, + ~signal: event => 'a, + ~inject: Update.t => 'a, + ~selected: option(Selection.t), + model: Model.t, + ) => { + ( + SlideContent.get_content( + List.nth(model.scratchpads, model.current) |> fst, + ) + |> Option.to_list + ) + @ [ + CellEditor.View.view( + ~globals, + ~signal= + fun + | MakeActive(selection) => signal(MakeActive(selection)), + ~inject=a => inject(CellAction(a)), + ~selected, + ~locked=false, + List.nth(model.scratchpads, model.current) |> snd, + ), + ]; + }; + + let file_menu = (~globals: Globals.t, ~inject: Update.t => 'a, _: Model.t) => { + let export_button = + Widgets.button_named( + Icons.export, + _ => inject(Export), + ~tooltip="Export Scratchpad", + ); + + let import_button = + Widgets.file_select_button_named( + "import-scratchpad", + Icons.import, + file => { + switch (file) { + | None => Virtual_dom.Vdom.Effect.Ignore + | Some(file) => inject(InitImportScratchpad(file)) + } + }, + ~tooltip="Import Scratchpad", + ); + + let file_group_scratch = + NutMenu.item_group(~inject, "File", [export_button, import_button]); + + let reset_button = + Widgets.button_named( + Icons.trash, + _ => { + let confirmed = + JsUtil.confirm( + "Are you SURE you want to reset this scratchpad? You will lose any existing code.", + ); + if (confirmed) { + inject(ResetCurrent); + } else { + Virtual_dom.Vdom.Effect.Ignore; + }; + }, + ~tooltip="Reset Editor", + ); + + let reparse = + Widgets.button_named( + Icons.backpack, + _ => globals.inject_global(ActiveEditor(Reparse)), + ~tooltip="Reparse Editor", + ); + + let reset_hazel = + Widgets.button_named( + Icons.bomb, + _ => { + let confirmed = + JsUtil.confirm( + "Are you SURE you want to reset Hazel to its initial state? You will lose any existing code that you have written, and course staff have no way to restore it!", + ); + if (confirmed) { + JsUtil.clear_localstore(); + Js_of_ocaml.Dom_html.window##.location##reload; + }; + Virtual_dom.Vdom.Effect.Ignore; + }, + ~tooltip="Reset Hazel (LOSE ALL DATA)", + ); + + let reset_group_scratch = + NutMenu.item_group( + ~inject, + "Reset", + [reset_button, reparse, reset_hazel], + ); + + [file_group_scratch, reset_group_scratch]; + }; + + let top_bar = + ( + ~globals as _, + ~named_slides: bool, + ~inject: Update.t => 'a, + model: Model.t, + ) => { + EditorModeView.view( + ~signal= + fun + | Previous => + inject( + SwitchSlide( + (model.current - 1) mod List.length(model.scratchpads), + ), + ) + | Next => + inject( + SwitchSlide( + (model.current + 1) mod List.length(model.scratchpads), + ), + ), + ~indicator= + named_slides + ? EditorModeView.indicator_select( + ~signal=i => inject(SwitchSlide(i)), + model.current, + List.map(((s, _)) => s, model.scratchpads), + ) + : EditorModeView.indicator_n( + model.current, + List.length(model.scratchpads), + ), + ); + }; +}; diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re index b3d3884c4d..5ea92c759d 100644 --- a/src/haz3lweb/view/StepperView.re +++ b/src/haz3lweb/view/StepperView.re @@ -1,221 +1,613 @@ -open Virtual_dom.Vdom; -open Node; +open Util; open Haz3lcore; +open Sexplib.Std; +open OptUtil.Syntax; -let settings_modal = (~inject, settings: CoreSettings.Evaluation.t) => { - let modal = div(~attrs=[Attr.class_("settings-modal")]); - let setting = (icon, name, current, action: UpdateAction.settings_action) => - div( - ~attrs=[Attr.class_("settings-toggle")], - [ - Widgets.toggle(~tooltip=name, icon, current, _ => - inject(Update.Set(action)) - ), - text(name), - ], +/* This file follows conventions in [docs/ui-architecture.md] */ + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type b = { + // Constants: + step: Haz3lcore.EvaluatorStep.EvalObj.t, + to_ids: list(Id.t), + // Calculated: + hidden: bool // Depends on settings + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type a' = { + // Constants: + expr: Exp.t, + state: EvaluatorState.t, + previous_substitutions: list(Id.t), + next_steps: list(b), + // Updated & Calculated: + editor: Calc.t(CodeSelectable.Model.t), + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type a = Calc.saved(a'); + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + // Calculated & Updated: + history: Aba.t(a, b), + // Calculated: + cached_settings: Calc.saved(CoreSettings.t), + cached_elab: Calc.saved(Exp.t), + }; + + let init = () => { + history: Aba.singleton(Calc.Pending), + cached_settings: Calc.Pending, + cached_elab: Calc.Pending, + }; + + let get_next_steps = (model: Aba.t(a, b)): list(b) => + model + |> Aba.hd + |> ( + fun + | Calculated({next_steps, _}) => { + next_steps; + } + | Pending => [] ); - [ - modal([ - div( - ~attrs=[Attr.class_("settings-modal-top")], - [ - Widgets.button(Icons.thin_x, _ => - inject(Update.Set(Evaluation(ShowSettings))) - ), - ], - ), - setting( - "h", - "show full step trace", - settings.stepper_history, - Evaluation(ShowRecord), - ), - setting( - "|", - "show case clauses", - settings.show_case_clauses, - Evaluation(ShowCaseClauses), - ), - setting( - "λ", - "show function bodies", - settings.show_fn_bodies, - Evaluation(ShowFnBodies), - ), - setting( - "x", - "show fixpoints", - settings.show_fixpoints, - Evaluation(ShowFixpoints), - ), - setting( - Unicode.castArrowSym, - "show casts", - settings.show_casts, - Evaluation(ShowCasts), - ), - setting( - "🔍", - "show lookup steps", - settings.show_lookup_steps, - Evaluation(ShowLookups), - ), - setting( - "⏯️", - "show stepper filters", - settings.show_stepper_filters, - Evaluation(ShowFilters), - ), - setting( - "🤫", - "show hidden steps", - settings.show_hidden_steps, - Evaluation(ShowHiddenSteps), - ), - ]), - div( - ~attrs=[ - Attr.class_("modal-back"), - Attr.on_mousedown(_ => - inject(Update.Set(Evaluation(ShowSettings))) - ), - ], - [], - ), - ]; + + let get_state = (model: Aba.t(a, b)): EvaluatorState.t => + model + |> Aba.hd + |> ( + fun + | Calculated({state, _}) => state + | Pending => EvaluatorState.init + ); + + let get_previous_substitutions = (model: Aba.t(a, b)): list(Id.t) => + model + |> Aba.hd + |> ( + fun + | Calculated({previous_substitutions, _}) => previous_substitutions + | Pending => [] + ); + + let get_elaboration = (model: t): option(Exp.t) => + model.history + |> Aba.last_a + |> ( + fun + | Calculated({expr, _}) => Some(expr) + | _ => None + ); + + let can_undo = (model: t) => { + model.history |> Aba.get_bs |> List.exists((b: b) => !b.hidden); + }; + + type persistent = list(Haz3lcore.EvaluatorStep.EvalObj.persistent); }; -let stepper_view = - ( - ~inject, - ~settings: CoreSettings.Evaluation.t, - ~font_metrics, - ~result_key, - ~read_only: bool, - stepper: Stepper.t, - ) => { - let step_dh_code = +module Update = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + // int here should include hidden steps + // Note this int is backwards compared to the selection (0 is the most recent step) + | StepperEditor(int, StepperEditor.Update.t) + | StepForward(int) + | StepBackward; + + let update = (~settings, action: t, model: Model.t): Updated.t(Model.t) => { + switch (action) { + | StepForward(idx) => + { + ...model, + history: + Aba.cons( + Calc.Pending, + Model.get_next_steps(model.history) |> List.nth(_, idx), + model.history, + ), + } + |> Updated.return + | StepBackward => + { + ...model, + history: { + let rec step_backward: + Aba.t(Model.a, Model.b) => Aba.t(Model.a, Model.b) = ( + fun + | ([_, ...as_], [{hidden: true, _}, ...bs]) => + (as_, bs) |> step_backward + | ([_, ...as_], [_, ...bs]) => (as_, bs) + | x => x + ); + step_backward(model.history); + }, + } + |> Updated.return + | StepperEditor(idx, x) => + { + ...model, + history: + model.history + |> Aba.get_as + |> ListUtil.map_nth( + idx, + Calc.map_saved((a: Model.a') => { + let editor = + CodeSelectable.Update.update( + ~settings, + x, + a.editor |> Calc.get_value, + ) + |> ((u: Updated.t('a)) => u.model); + let editor = Calc.NewValue(editor); + {...a, editor}; + }), + ) + |> Aba.mk(_, model.history |> Aba.get_bs), + } + |> Updated.return(~is_edit=false) + }; + }; + + open Calc.Syntax; + + let calc_next_steps = (settings: CoreSettings.t, expr, state) => + EvaluatorStep.decompose(expr, state) + |> List.map( + EvaluatorStep.should_hide_eval_obj(~settings=settings.evaluation), + ) + |> List.map( + fun + | (FilterAction.Step, x) => + Model.{hidden: false, step: x, to_ids: [Id.mk()]} + | (FilterAction.Eval, x) => + Model.{hidden: true, step: x, to_ids: [Id.mk()]}, + ); + + let get_next_a = ( - ~next_steps, - {previous_step, hidden_steps, chosen_step, d}: Stepper.step_info, - ) => - div( - ~attrs=[Attr.classes(["result"])], - [ - DHCode.view( - ~inject, + ~settings: Calc.t('a), + prev_a: Calc.t(Model.a'), + b: Model.b, + old_a: Calc.saved(Model.a'), + ) => { + old_a + |> Calc.map_saved(Option.some) + // Only perform below if either previous a or settings have changed + |> { + let.calc {expr: _, state, previous_substitutions, next_steps, _} = prev_a + and.calc settings: Calc.t(CoreSettings.t) = settings; + + // Check b is valid + let* b = + List.find_opt( + (b': Model.b) => b'.step.d_loc.ids == b.step.d_loc.ids, + next_steps, + ); + + // Use b + let state = ref(state); + let+ next_expr = + EvaluatorStep.take_step(state, b.step.env, b.step.d_loc); + let next_expr = {...next_expr, ids: b.to_ids}; + let next_state = state^; + let previous_substitutions = + ( + b.step.knd == Transition.VarLookup + ? [b.step.d_loc |> Exp.rep_id] : [] + ) + @ ( + previous_substitutions + |> List.map((id: Id.t) => + if (id == (b.step.d_loc |> Exp.rep_id)) { + next_expr |> Exp.rep_id; + } else { + id; + } + ) + ); + let next_expr = + EvalCtx.compose(b.step.ctx, next_expr) + |> ( + settings.evaluation.show_casts ? x => x : Haz3lcore.DHExp.strip_casts + ) + |> Typ.replace_temp_exp; + let editor = CodeWithStatics.Model.mk_from_exp(~settings, next_expr); + let next_steps = calc_next_steps(settings, next_expr, next_state); + ( + { + expr: next_expr, + state: next_state, + previous_substitutions, + editor: Calc.NewValue(editor), + next_steps, + }: Model.a' + ); + }; + }; + + let rec take_hidden_steps = + ( + ~settings, + prev_a: Calc.t(Model.a'), + history: Aba.t(Model.a, Model.b), + ) + : Aba.t(Model.a, Model.b) => { + let next_steps = Model.get_next_steps(history); + let hidden_steps = List.filter((s: Model.b) => s.hidden, next_steps); + switch (hidden_steps) { + | [] => history + | [x, ..._] => + switch ( + get_next_a(~settings, prev_a, x, Calc.Pending) |> Calc.to_option + ) { + | Some(a') => + take_hidden_steps( ~settings, - ~selected_hole_instance=None, - ~font_metrics, - ~width=80, - ~previous_step, - ~chosen_step, - ~hidden_steps, - ~result_key, - ~next_steps, - ~infomap=Id.Map.empty, - d, - ), - ], + a', + Aba.cons(a' |> Calc.save, x, history), + ) + | None => failwith("Unable to take step!") + } + }; + }; + + let calculate_editors = + (~settings, history: Aba.t(Model.a, Model.b)): Aba.t(Model.a, Model.b) => { + history + |> Aba.map_a( + Calc.map_saved((Model.{editor, _} as a) => { + editor + |> Calc.map_if_new( + CodeSelectable.Update.calculate( + ~settings=settings |> Calc.get_value, + ~is_edited=false, + ~stitch=x => + x + ), + ) + |> (editor => {...a, editor}) + }), + ); + }; + + let calculate = + ( + ~settings, + elab: Exp.t, + {history, cached_settings, cached_elab}: Model.t, + ) => { + let settings = + cached_settings + |> Calc.set(settings, ~eq=(a, b) => { + CoreSettings.{ + ...a, + evaluation: { + ...a.evaluation, + show_settings: true, + stepper_history: true, + }, + } + == CoreSettings.{ + ...b, + evaluation: { + ...b.evaluation, + show_settings: true, + stepper_history: true, + }, + } + }); + let elab = cached_elab |> Calc.set(~eq=Exp.fast_equal, elab); + + let (prev_a, history) = + Aba.fold_right( + (a: Model.a, b: Model.b, (prev_a: Calc.t(Model.a'), history)) => { + let next_a = get_next_a(~settings, prev_a, b, a) |> Calc.to_option; + switch (next_a) { + | None => (prev_a, history) + | Some(next_a) => ( + next_a, + Aba.cons(next_a |> Calc.save, b, history), + ) + }; + }, + (old_a: Model.a) => { + let new_a = + old_a + |> { + let.calc elab = elab + and.calc settings = settings; + let elab = + elab + |> ( + settings.evaluation.show_casts + ? x => x : Haz3lcore.DHExp.strip_casts + ) + |> Typ.replace_temp_exp; + let editor = CodeWithStatics.Model.mk_from_exp(~settings, elab); + let next_steps = + calc_next_steps(settings, elab, EvaluatorState.init); + Model.{ + expr: elab, + state: EvaluatorState.init, + previous_substitutions: [], + editor: Calc.NewValue(editor), + next_steps, + }; + }; + (new_a, Aba.singleton(new_a |> Calc.save)); + }, + history, + ); + + Model.{ + history: + history + |> take_hidden_steps(~settings, prev_a) + |> calculate_editors(~settings), + cached_settings: settings |> Calc.save, + cached_elab: elab |> Calc.save, + }; + }; +}; + +module Selection = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + // int here should include hidden steps + // Note this int is backwards compared to the editors (so that 0 is the oldest step, and selections are preserved) + | A(int, StepperEditor.Selection.t); + + let get_cursor_info = (~selection: t, mr: Model.t): Cursor.cursor(Update.t) => { + Cursor.( + switch (selection) { + | A(n, editor_selection) => + let a: option(Model.a) = + mr.history + |> Aba.get_as + |> List.nth_opt(_, List.length(mr.history |> Aba.get_as) - n - 1); + switch (a) { + | Some(Calculated(a)) => + let+ x = + StepperEditor.Selection.get_cursor_info( + ~selection=editor_selection, + a.editor |> Calc.get_value, + ); + Update.StepperEditor(n, x); + | None + | Some(Pending) => empty + }; + } ); - let history = Stepper.get_history(~settings, stepper); - switch (history) { - | [] => [] - | [hd, ...tl] => + }; + + let handle_key_event = + (~selection: t, ~event, mr: Model.t): option(Update.t) => { + let A(i, s) = selection; + let a: option(Model.a) = + mr.history + |> Aba.get_as + |> List.nth_opt(_, List.length(mr.history |> Aba.get_as) - i - 1); + switch (a) { + | Some(Calculated(a)) => + let+ x = + StepperEditor.Selection.handle_key_event( + ~selection=s, + a.editor |> Calc.get_value, + event, + ); + Update.StepperEditor(i, x); + | Some(Pending) + | None => None + }; + }; +}; + +module View = { + open Virtual_dom.Vdom; + open Node; + + type event = + | HideStepper + | JumpTo(Haz3lcore.Id.t) + | MakeActive(Selection.t); + + let view = + ( + ~globals as {settings, inject_global, _} as globals: Globals.t, + ~signal: event => Ui_effect.t(unit), + ~inject: Update.t => Ui_effect.t(unit), + ~selection: option(Selection.t), + ~read_only: bool, + stepper: Model.t, + ) => { let button_back = Widgets.button_d( Icons.undo, - inject(UpdateAction.StepperAction(result_key, StepBackward)), - ~disabled=!Stepper.can_undo(~settings, stepper), + inject(StepBackward), + ~disabled=!Model.can_undo(stepper), ~tooltip="Step Backwards", ); let button_hide_stepper = Widgets.toggle(~tooltip="Show Stepper", "s", true, _ => - inject(UpdateAction.ToggleStepper(result_key)) + signal(HideStepper) ); let toggle_show_history = - Widgets.toggle(~tooltip="Show History", "h", settings.stepper_history, _ => - inject(Set(Evaluation(ShowRecord))) + Widgets.toggle( + ~tooltip="Show History", + "h", + settings.core.evaluation.stepper_history, + _ => + inject_global(Set(Evaluation(ShowRecord))) ); let eval_settings = Widgets.button(Icons.gear, _ => - inject(Set(Evaluation(ShowSettings))) + inject_global(Set(Evaluation(ShowSettings))) ); - let current = + let previous_steps = { + stepper.history + |> Aba.aba_triples + |> (settings.core.evaluation.stepper_history ? x => x : (_ => [])) + |> List.mapi((i, x) => (i, x)) + |> ( + settings.core.evaluation.show_hidden_steps + ? x => x : List.filter(((_, (_, b: Model.b, _))) => !b.hidden) + ) + |> List.map(((i, (_, b: Model.b, a: Model.a))) => + switch (a) { + | Calculated(a) => + [ + div( + ~attrs=[ + Attr.classes( + ["cell-item", "cell-result"] + @ (b.hidden ? ["hidden"] : []), + ), + ], + [ + div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), + StepperEditor.View.view( + ~globals, + ~overlays=[], + ~selected= + selection + == Some( + A( + List.length(stepper.history |> Aba.get_as) + - (i + 1) + - 1, + (), + ), + ), + ~inject= + (x: StepperEditor.Update.t) => + inject(StepperEditor(i + 1, x)), + ~signal= + fun + | TakeStep(_) => Ui_effect.Ignore + | MakeActive => + signal( + MakeActive( + A( + List.length(stepper.history |> Aba.get_as) + - (i + 1) + - 1, + (), + ), + ), + ), + { + editor: a.editor |> Calc.get_value, + next_steps: [], + taken_steps: [b.step.d_loc |> Exp.rep_id], + }, + ) + |> (x => [x]) + |> Web.div_c("result"), + div( + ~attrs=[Attr.classes(["stepper-justification"])], + [ + b.step.knd + |> Transition.stepper_justification + |> Node.text, + ], + ), + ], + ), + ] + |> List.rev + | Pending => [ + div(~attrs=[Attr.class_("cell-item")], [text("...")]), + ] + } + ) + |> List.rev + |> List.flatten; + }; + let current_step = { + let model = stepper.history |> Aba.hd; + let current_n = 0; div( ~attrs=[Attr.classes(["cell-item", "cell-result"])], - read_only - ? [ - div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), - step_dh_code(~next_steps=[], hd), - ] - : [ - div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), - step_dh_code( - ~next_steps= - List.mapi( - (i, x: EvaluatorStep.EvalObj.t) => - (i, x.d_loc |> DHExp.rep_id), - Stepper.get_next_steps(stepper), - ), - hd, - ), - button_back, - eval_settings, - toggle_show_history, - button_hide_stepper, - ], - ); - let dh_code_previous = step_dh_code; - let rec previous_step = - (~hidden: bool, step: Stepper.step_info): list(Node.t) => { - let hidden_steps = - settings.show_hidden_steps - ? Stepper.hidden_steps_of_info(step) - |> List.rev_map(previous_step(~hidden=true)) - |> List.flatten - : []; - [ - div( - ~attrs=[ - Attr.classes( - ["cell-item", "cell-result"] @ (hidden ? ["hidden"] : []), - ), - ], - [ - div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), - dh_code_previous(~next_steps=[], step), - div( - ~attrs=[Attr.classes(["stepper-justification"])], - step.chosen_step - |> Option.map((chosen_step: EvaluatorStep.step) => - chosen_step.knd |> Stepper.get_justification |> Node.text - ) - |> Option.to_list, - ), - ], + ( + switch (model) { + | Calculated(model) => [ + div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), + StepperEditor.View.view( + ~globals, + ~selected= + selection + == Some( + A( + List.length(stepper.history |> Aba.get_as) + - current_n + - 1, + (), + ), + ), + ~inject= + (x: StepperEditor.Update.t) => + inject(StepperEditor(current_n, x)), + ~signal= + fun + | TakeStep(x) => + Effect.Many([ + inject(Update.StepForward(x)), + Effect.Stop_propagation, + ]) + | MakeActive => + signal( + MakeActive( + A( + List.length(stepper.history |> Aba.get_as) + - current_n + - 1, + (), + ), + ), + ), + ~overlays=[], + { + editor: model.editor |> Calc.get_value, + next_steps: + List.map( + (option: Model.b) => option.step.d_loc |> Exp.rep_id, + model.next_steps, + ), + taken_steps: [], + }, + ) + |> (x => [x]) + |> Web.div_c("result"), + ] + | Pending => [ + div(~attrs=[Attr.class_("cell-item")], [text("...")]), + ] + } + ) + @ ( + read_only + ? [] + : [ + button_back, + eval_settings, + toggle_show_history, + button_hide_stepper, + ] ), - ] - @ hidden_steps; + ); }; - ( - ( - settings.stepper_history - ? List.map(previous_step(~hidden=false), tl) - |> List.flatten - |> List.rev_append( - _, - settings.show_hidden_steps - ? hd - |> Stepper.hidden_steps_of_info - |> List.map(previous_step(~hidden=true)) - |> List.flatten - : [], - ) - : [] - ) - @ [current] - ) - @ (settings.show_settings ? settings_modal(~inject, settings) : []); + let settings_modal = + settings.core.evaluation.show_settings + ? SettingsModal.view( + ~inject=u => inject_global(Set(u)), + settings.core.evaluation, + ) + : []; + previous_steps @ [current_step] @ settings_modal; }; }; diff --git a/src/haz3lweb/view/TestView.re b/src/haz3lweb/view/TestView.re index 1b01158c56..ecfddcea56 100644 --- a/src/haz3lweb/view/TestView.re +++ b/src/haz3lweb/view/TestView.re @@ -5,122 +5,19 @@ open Util.Web; module TestStatus = Haz3lcore.TestStatus; module TestMap = Haz3lcore.TestMap; module TestResults = Haz3lcore.TestResults; -module Interface = Haz3lcore.Interface; -let test_instance_view = - ( - ~settings, - ~inject, - ~font_metrics, - ~infomap, - (d, status): TestMap.instance_report, - ) => - div( - ~attrs=[clss(["test-instance", TestStatus.to_string(status)])], - [ - DHCode.view( - ~inject, - ~settings, - ~selected_hole_instance=None, - ~font_metrics, - ~width=40, - ~result_key="", - ~infomap, - d, - ), - ], - ); - -let jump_to_test = (~inject, pos, id, _) => { - let effect1 = inject(Update.SwitchEditor(pos)); - let effect2 = inject(Update.PerformAction(Jump(TileId(id)))); - Effect.bind(effect1, ~f=_result1 => effect2); -}; - -let test_report_view = - ( - ~settings, - ~inject, - ~font_metrics, - ~description: option(string)=None, - ~infomap, - i: int, - (id, instance_reports): TestMap.report, - ) => { - let status = - instance_reports |> TestMap.joint_status |> TestStatus.to_string; - div( - ~attrs=[ - Attr.class_("test-report"), - Attr.on_click(jump_to_test(~inject, YourTestsTesting, id)), - ], - [ - div( - ~attrs=[clss(["test-id", "Test" ++ status])], - // note: prints lexical index, not id - [text(string_of_int(i + 1))], - ), - div( - ~attrs=[Attr.class_("test-instances")], - List.map( - test_instance_view(~infomap, ~settings, ~inject, ~font_metrics), - instance_reports, - ), - ), - ] - @ ( - switch (description) { - | None => [] - | Some(d) => [div(~attrs=[clss(["test-description"])], [text(d)])] - } - ), - ); -}; - -let test_reports_view = - ( - ~settings, - ~inject, - ~font_metrics, - ~infomap, - ~test_results: option(TestResults.t), - ) => - div( - ~attrs=[clss(["panel-body", "test-reports"])], - switch (test_results) { - | None => [Node.text("No test report available.")] - | Some(test_results) => - List.mapi( - (i, r) => - test_report_view( - ~settings, - ~inject, - ~font_metrics, - ~infomap, - ~description=List.nth_opt(test_results.descriptions, i), - i, - r, - ), - test_results.test_map, - ) - }, - ); - -let test_bar_segment = (~inject, pos, (id, reports)) => { +let test_bar_segment = (~inject_jump, (id, reports)) => { let status = reports |> TestMap.joint_status |> TestStatus.to_string; div( - ~attrs=[ - clss(["segment", status]), - Attr.on_click(jump_to_test(~inject, pos, id)), - ], + ~attrs=[clss(["segment", status]), Attr.on_click(_ => inject_jump(id))], [], ); }; -let test_bar = (~inject, ~test_results: TestResults.t, pos) => +let test_bar = (~inject_jump, ~test_results: TestResults.t) => div( ~attrs=[Attr.class_("test-bar")], - List.map(test_bar_segment(~inject, pos), test_results.test_map), + List.map(test_bar_segment(~inject_jump), test_results.test_map), ); // result_summary_str and test_summary_str have been moved to haz3lcore/TestResults.re @@ -147,7 +44,7 @@ let test_text = (test_results: TestResults.t): Node.t => ], ); -let test_summary = (~inject, ~test_results: option(TestResults.t)) => { +let test_summary = (~inject_jump, ~test_results: option(TestResults.t)) => { div( ~attrs=[clss(["test-summary"])], { @@ -155,7 +52,7 @@ let test_summary = (~inject, ~test_results: option(TestResults.t)) => { | None => [Node.text("No test results available.")] | Some(test_results) => [ test_text(test_results), - test_bar(~inject, ~test_results, YourTestsTesting), + test_bar(~inject_jump, ~test_results), ] }; }, @@ -167,33 +64,3 @@ let view_of_main_title_bar = (title_text: string) => ~attrs=[clss(["title-bar", "panel-title-bar"])], [Node.text(title_text)], ); - -let inspector_view = - ( - ~settings, - ~inject, - ~font_metrics, - ~test_map: TestMap.t, - ~infomap, - id: Haz3lcore.Id.t, - ) - : option(t) => { - switch (TestMap.lookup(id, test_map)) { - | Some(instances) when TestMap.joint_status(instances) != Indet => - Some( - div( - ~attrs=[Attr.class_("test-inspector")], - [ - div( - ~attrs=[Attr.class_("test-instances")], - List.map( - test_instance_view(~settings, ~inject, ~font_metrics, ~infomap), - instances, - ), - ), - ], - ), - ) - | _ => None - }; -}; diff --git a/src/haz3lweb/view/Type.re b/src/haz3lweb/view/Type.re deleted file mode 100644 index 82dfd0a9e3..0000000000 --- a/src/haz3lweb/view/Type.re +++ /dev/null @@ -1,124 +0,0 @@ -open Virtual_dom.Vdom; -open Node; -open Util.Web; -open Haz3lcore; - -let tpat_view = (tpat: Haz3lcore.TPat.t): string => - switch (tpat.term) { - | Var(x) => x - | _ => "?" - }; - -let ty_view = (cls: string, s: string): Node.t => - div(~attrs=[clss(["typ-view", cls])], [text(s)]); - -let alias_view = (s: string): Node.t => - div(~attrs=[clss(["typ-alias-view"])], [text(s)]); - -let rec view_ty = (~strip_outer_parens=false, ty: Haz3lcore.Typ.t): Node.t => - switch (Typ.term_of(ty)) { - | Unknown(prov) => - div( - ~attrs=[ - clss(["typ-view", "atom", "unknown"]), - Attr.title(TermBase.show_type_provenance(prov)), - ], - [text("?") /*, prov_view(prov)*/], - ) - | Parens(ty) => view_ty(ty) - | Int => ty_view("Int", "Int") - | Float => ty_view("Float", "Float") - | String => ty_view("String", "String") - | Bool => ty_view("Bool", "Bool") - | Var(name) => ty_view("Var", name) - | Rec(name, t) => - div( - ~attrs=[clss(["typ-view", "Rec"])], - [text("Rec " ++ tpat_view(name) ++ ". "), view_ty(t)], - ) - | Forall(name, t) => - div( - ~attrs=[clss(["typ-view", "Forall"])], - [text("forall " ++ tpat_view(name) ++ " -> "), view_ty(t)], - ) - | List(t) => - div( - ~attrs=[clss(["typ-view", "atom", "List"])], - [text("["), view_ty(t), text("]")], - ) - | Arrow(t1, t2) => - div( - ~attrs=[clss(["typ-view", "Arrow"])], - paren_view(t1) @ [text(" -> "), view_ty(t2)], - ) - | Prod([]) => div(~attrs=[clss(["typ-view", "Prod"])], [text("()")]) - | Prod([_]) => - div(~attrs=[clss(["typ-view", "Prod"])], [text("Singleton Product")]) - | Prod([t0, ...ts]) => - div( - ~attrs=[clss(["typ-view", "atom", "Prod"])], - ( - if (!strip_outer_parens) { - [text("(")]; - } else { - []; - } - ) - @ [ - div( - ~attrs=[clss(["typ-view", "Prod"])], - paren_view(t0) - @ ( - List.map(t => [text(", "), ...paren_view(t)], ts) - |> List.flatten - ), - ), - ] - @ ( - if (!strip_outer_parens) { - [text(")")]; - } else { - []; - } - ), - ) - | Sum(ts) => - div( - ~attrs=[clss(["typ-view", "Sum"])], - switch (ts) { - | [] => [text("Nullary Sum")] - | [t0] => [text("+")] @ ctr_view(t0) - | [t0, ...ts] => - let ts_views = - List.map(t => [text(" + ")] @ ctr_view(t), ts) |> List.flatten; - ctr_view(t0) @ ts_views; - }, - ) - | Ap(_) => - div( - ~attrs=[ - clss(["typ-view", "atom", "unknown"]), - Attr.title(TermBase.show_type_provenance(Internal)), - ], - [text("?") /*, prov_view(prov)*/], - ) - } -and ctr_view = - fun - | Variant(ctr, _, None) => [text(ctr)] - | Variant(ctr, _, Some(typ)) => [ - text(ctr ++ "("), - view_ty(typ), - text(")"), - ] - | BadEntry(typ) => [view_ty(typ)] - -and paren_view = typ => - if (Typ.needs_parens(typ)) { - [text("("), view_ty(~strip_outer_parens=true, typ), text(")")]; - } else { - [view_ty(typ)]; - }; - -let view = (ty: Haz3lcore.Typ.t): Node.t => - div(~attrs=[clss(["type", "code"])], [view_ty(ty)]); diff --git a/src/haz3lweb/view/dhcode/DHCode.re b/src/haz3lweb/view/dhcode/DHCode.re deleted file mode 100644 index b28f9e18bf..0000000000 --- a/src/haz3lweb/view/dhcode/DHCode.re +++ /dev/null @@ -1,160 +0,0 @@ -open Virtual_dom; -open Virtual_dom.Vdom; -open Util; -open Pretty; -open Haz3lcore; - -let with_cls = cls => Node.span(~attrs=[Attr.classes([cls])]); - -let view_of_layout = - (~inject, ~font_metrics: FontMetrics.t, ~result_key, l: DHLayout.t) - : Node.t => { - let corner_radii = Decoration_common.corner_radii(font_metrics); - let (text, decorations) = - DHMeasuredLayout.mk(l) - |> MeasuredLayout.pos_fold( - ~linebreak=_ => ([Node.br()], []), - ~text=(_, s) => ([Node.text(s)], []), - ~align= - (_, (txt, ds)) => - ([Node.div(~attrs=[Attr.classes(["Align"])], txt)], ds), - ~cat=(_, (txt1, ds1), (txt2, ds2)) => (txt1 @ txt2, ds1 @ ds2), - ~annot= - (~go, ~indent, ~start, annot: DHAnnot.t, m) => { - let (txt, ds) = go(m); - switch (annot) { - | Steppable(obj) => ( - [ - Node.span( - ~attrs=[ - Attr.class_("steppable"), - Attr.on_click(_ => - inject( - UpdateAction.StepperAction( - result_key, - StepForward(obj), - ), - ) - ), - ], - txt, - ), - ], - ds, - ) - | Stepped => ( - [Node.span(~attrs=[Attr.class_("stepped")], txt)], - ds, - ) - | Substituted => ( - [Node.span(~attrs=[Attr.class_("substituted")], txt)], - ds, - ) - | Step(_) - | Term => (txt, ds) - | Collapsed => ([with_cls("Collapsed", txt)], ds) - | HoleLabel => ([with_cls("HoleLabel", txt)], ds) - | Delim => ([with_cls("code-delim", txt)], ds) - | EmptyHole(selected, _inst) => ( - [ - Node.span( - ~attrs=[ - Attr.classes([ - "EmptyHole", - ...selected ? ["selected"] : [], - ]), - Attr.on_click(_ => - Vdom.Effect.Many([ - Vdom.Effect.Stop_propagation, - //inject(ModelAction.SelectHoleInstance(inst)), - ]) - ), - ], - txt, - ), - ], - ds, - ) - | FailedCastDelim => ([with_cls("FailedCastDelim", txt)], ds) - | FailedCastDecoration => ( - [with_cls("FailedCastDecoration", txt)], - ds, - ) - | CastDecoration => ([with_cls("CastDecoration", txt)], ds) - | OperationError( - DivideByZero | InvalidOfString | IndexOutOfBounds, - ) => ( - [with_cls("OperationError", txt)], - ds, - ) - | OperationError(NegativeExponent) => ( - [with_cls("OperationError", txt)], - ds, - ) - | OperationError(OutOfFuel) => ( - [with_cls("OperationError", txt)], - ds, - ) - | VarHole(_) => ([with_cls("InVarHole", txt)], ds) - | NonEmptyHole - | InconsistentBranches(_) - | Invalid => - let offset = start.col - indent; - let decoration = - Decoration_common.container( - ~container_type=Svg, - ~font_metrics, - ~height=MeasuredLayout.height(m), - ~width=MeasuredLayout.width(~offset, m), - ~origin=MeasuredPosition.{row: start.row, col: indent}, - ~cls="err-hole", - [DHDecoration.ErrHole.view(~corner_radii, (offset, m))], - ); - (txt, [decoration, ...ds]); - }; - }, - ); - Node.div( - ~attrs=[Attr.classes(["DHCode"])], - [with_cls("code", text), ...decorations], - ); -}; - -let view = - ( - ~locked as _=false, // NOTE: When we add mouse events to this, ignore them if locked - ~inject, - ~settings: CoreSettings.Evaluation.t, - ~selected_hole_instance: option(Id.t), - ~font_metrics: FontMetrics.t, - ~width: int, - ~pos=0, - ~previous_step: option((EvaluatorStep.step, Id.t))=None, // The step that will be displayed above this one - ~hidden_steps: list((EvaluatorStep.step, Id.t))=[], // The hidden steps between the above and the current one - ~chosen_step: option(EvaluatorStep.step)=None, // The step that will be taken next - ~next_steps: list((int, Id.t))=[], - ~result_key: string, - ~infomap, - d: DHExp.t, - ) - : Node.t => { - DHDoc_Exp.mk( - ~previous_step, - ~hidden_steps, - ~chosen_step, - ~next_steps, - ~env=ClosureEnvironment.empty, - ~settings, - ~enforce_inline=false, - ~selected_hole_instance, - ~infomap, - d, - ) - |> LayoutOfDoc.layout_of_doc(~width, ~pos) - |> OptUtil.get(() => - failwith("unimplemented: view_of_dhexp on layout failure") - ) - |> view_of_layout(~inject, ~font_metrics, ~result_key); -}; - -type font_metrics = FontMetrics.t; diff --git a/src/haz3lweb/view/dhcode/DHDecoration.re b/src/haz3lweb/view/dhcode/DHDecoration.re deleted file mode 100644 index acd8532f3c..0000000000 --- a/src/haz3lweb/view/dhcode/DHDecoration.re +++ /dev/null @@ -1,2 +0,0 @@ -module ErrHole = Decoration_common.ErrHole; -module VarErrHole = Decoration_common.VarErrHole; diff --git a/src/haz3lweb/view/dhcode/Decoration_common.re b/src/haz3lweb/view/dhcode/Decoration_common.re deleted file mode 100644 index 2be3d88be8..0000000000 --- a/src/haz3lweb/view/dhcode/Decoration_common.re +++ /dev/null @@ -1,176 +0,0 @@ -open Virtual_dom.Vdom; - -module MeasuredPosition = Pretty.MeasuredPosition; -module MeasuredLayout = Pretty.MeasuredLayout; - -type container_type = - | Svg - | Div; - -/** - * A buffered container for SVG elements so that strokes along - * the bounding box of the elements do not get clipped by the - * viewBox boundaries - */ -let container = - ( - ~container_type: container_type, - ~font_metrics: FontMetrics.t, - ~origin: MeasuredPosition.t, - ~height: int, - ~width: int, - ~cls: string, - contents: list(Node.t), - ) - : Node.t => { - let buffered_height = height; - let buffered_width = width; - - let buffered_height_px = - Float.of_int(buffered_height) *. font_metrics.row_height; - let buffered_width_px = - Float.of_int(buffered_width) *. font_metrics.col_width; - - let container_origin_x = - Float.of_int(origin.row) *. font_metrics.row_height; - let container_origin_y = Float.of_int(origin.col) *. font_metrics.col_width; - - let inner = - switch (container_type) { - | Div => - Node.div( - ~attrs=[ - Attr.classes([ - "decoration-container", - Printf.sprintf("%s-container", cls), - ]), - Attr.create( - "style", - Printf.sprintf( - "width: %fpx; height: %fpx;", - buffered_width_px, - buffered_height_px, - ), - ), - ], - contents, - ) - | Svg => - Node.create_svg( - "svg", - ~attrs=[ - Attr.classes([cls]), - Attr.create( - "viewBox", - Printf.sprintf("0 0 %d %d", buffered_width, buffered_height), - ), - Attr.create("width", Printf.sprintf("%fpx", buffered_width_px)), - Attr.create("height", Printf.sprintf("%fpx", buffered_height_px)), - Attr.create("preserveAspectRatio", "none"), - ], - contents, - ) - }; - Node.div( - ~attrs=[ - Attr.classes([ - "decoration-container", - Printf.sprintf("%s-container", cls), - ]), - Attr.create( - "style", - Printf.sprintf( - "top: calc(%fpx); left: %fpx;", - container_origin_x, - container_origin_y, - ), - ), - ], - [inner], - ); -}; - -let corner_radii = (font_metrics: FontMetrics.t) => { - let r = 2.5; - (r /. font_metrics.col_width, r /. font_metrics.row_height); -}; - -let rects = - ( - ~indent=0, - ~vtrim=0.0, - start: MeasuredPosition.t, - m: MeasuredLayout.t(_), - ) - : list(SvgUtil.Rect.t) => { - let mk_rect = - ( - ~is_first=false, - ~is_last=false, - start: MeasuredPosition.t, - box: MeasuredLayout.box, - ) => - SvgUtil.Rect.{ - min: { - x: Float.of_int(start.col), - y: Float.of_int(start.row) +. (is_first ? vtrim : 0.0), - }, - width: Float.of_int(box.width), - height: - Float.of_int(box.height) - -. (is_first ? vtrim : 0.0) - -. (is_last ? vtrim : 0.0), - }; - let n = List.length(m.metrics); - m.metrics - |> List.mapi((i, box) => (i, box)) - |> List.fold_left_map( - (start: MeasuredPosition.t, (i, box: MeasuredLayout.box)) => - ( - {row: start.row + box.height, col: indent}, - mk_rect(~is_first=i == 0, ~is_last=i == n - 1, start, box), - ), - start, - ) - |> snd; -}; - -module ErrHole = { - let view = - ( - ~vtrim=0., - ~corner_radii: (float, float), - (offset, subject): MeasuredLayout.with_offset(_), - ) - : Node.t => - subject - |> rects(~vtrim, {row: 0, col: offset}) - |> SvgUtil.OrthogonalPolygon.mk(~corner_radii) - |> SvgUtil.Path.view( - ~attrs= - Attr.[ - classes(["err-hole"]), - create("vector-effect", "non-scaling-stroke"), - ], - ); -}; - -module VarErrHole = { - let view = - ( - ~vtrim=0., - ~corner_radii: (float, float), - (offset, subject): MeasuredLayout.with_offset(_), - ) - : Node.t => - subject - |> rects(~vtrim, {row: 0, col: offset}) - |> SvgUtil.OrthogonalPolygon.mk(~corner_radii) - |> SvgUtil.Path.view( - ~attrs= - Attr.[ - classes(["var-err-hole"]), - create("vector-effect", "non-scaling-stroke"), - ], - ); -}; diff --git a/src/haz3lweb/view/dhcode/layout/DHAnnot.re b/src/haz3lweb/view/dhcode/layout/DHAnnot.re deleted file mode 100644 index 2b351315d3..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHAnnot.re +++ /dev/null @@ -1,22 +0,0 @@ -open Util; -open Haz3lcore; - -[@deriving sexp] -type t = - | Collapsed - | Step(int) - | Term - | HoleLabel - | Delim - | EmptyHole(bool, ClosureEnvironment.t) - | NonEmptyHole - | VarHole(VarErrStatus.HoleReason.t, Id.t) - | InconsistentBranches(Id.t) - | Invalid - | FailedCastDelim - | FailedCastDecoration - | CastDecoration - | OperationError(InvalidOperationError.t) - | Steppable(int) - | Stepped - | Substituted; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc.re b/src/haz3lweb/view/dhcode/layout/DHDoc.re deleted file mode 100644 index b9d19c57cf..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc.re +++ /dev/null @@ -1,4 +0,0 @@ -open Pretty; - -[@deriving sexp] -type t = Doc.t(DHAnnot.t); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re deleted file mode 100644 index ffb0eed0c5..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Exp.re +++ /dev/null @@ -1,670 +0,0 @@ -open Haz3lcore; -open EvaluatorStep; -open Transition; -module Doc = Pretty.Doc; - -let precedence_bin_bool_op = (op: Operators.op_bin_bool) => - switch (op) { - | And => DHDoc_common.precedence_And - | Or => DHDoc_common.precedence_Or - }; - -let precedence_bin_int_op = (bio: Operators.op_bin_int) => - switch (bio) { - | Times => DHDoc_common.precedence_Times - | Power => DHDoc_common.precedence_Power - | Divide => DHDoc_common.precedence_Divide - | Plus => DHDoc_common.precedence_Plus - | Minus => DHDoc_common.precedence_Minus - | Equals => DHDoc_common.precedence_Equals - | NotEquals => DHDoc_common.precedence_Equals - | LessThan => DHDoc_common.precedence_LessThan - | LessThanOrEqual => DHDoc_common.precedence_LessThan - | GreaterThan => DHDoc_common.precedence_GreaterThan - | GreaterThanOrEqual => DHDoc_common.precedence_GreaterThan - }; -let precedence_bin_float_op = (bfo: Operators.op_bin_float) => - switch (bfo) { - | Times => DHDoc_common.precedence_Times - | Power => DHDoc_common.precedence_Power - | Divide => DHDoc_common.precedence_Divide - | Plus => DHDoc_common.precedence_Plus - | Minus => DHDoc_common.precedence_Minus - | Equals => DHDoc_common.precedence_Equals - | NotEquals => DHDoc_common.precedence_Equals - | LessThan => DHDoc_common.precedence_LessThan - | LessThanOrEqual => DHDoc_common.precedence_LessThan - | GreaterThan => DHDoc_common.precedence_GreaterThan - | GreaterThanOrEqual => DHDoc_common.precedence_GreaterThan - }; -let precedence_bin_string_op = (bso: Operators.op_bin_string) => - switch (bso) { - | Concat => DHDoc_common.precedence_Plus - | Equals => DHDoc_common.precedence_Equals - }; -let rec precedence = (~show_function_bodies, ~show_casts: bool, d: DHExp.t) => { - let precedence' = precedence(~show_function_bodies, ~show_casts); - switch (DHExp.term_of(d)) { - | Var(_) - | Invalid(_) - | Bool(_) - | Int(_) - | Seq(_) - | Test(_) - | Float(_) - | String(_) - | ListLit(_) - | EmptyHole - | Constructor(_) - | FailedCast(_) - | DynamicErrorHole(_) - | If(_) - | Closure(_) - | BuiltinFun(_) - | Deferral(_) - | Undefined - | Filter(_) => DHDoc_common.precedence_const - | Cast(d1, _, _) => - show_casts ? DHDoc_common.precedence_Ap : precedence'(d1) - | DeferredAp(_) - | Ap(_) - | TypAp(_) => DHDoc_common.precedence_Ap - | Cons(_) => DHDoc_common.precedence_Cons - | ListConcat(_) => DHDoc_common.precedence_Plus - | Tuple(_) => DHDoc_common.precedence_Comma - | TypFun(_) - | Fun(_) when !show_function_bodies => DHDoc_common.precedence_const - | TypFun(_) - | Fun(_) => DHDoc_common.precedence_max - | Let(_) - | TyAlias(_) - | FixF(_) - | Match(_) => DHDoc_common.precedence_max - | UnOp(Meta(Unquote), _) => DHDoc_common.precedence_Ap - | UnOp(Bool(Not), _) => DHDoc_common.precedence_Not - | UnOp(Int(Minus), _) => DHDoc_common.precedence_Minus - | BinOp(Bool(op), _, _) => precedence_bin_bool_op(op) - | BinOp(Int(op), _, _) => precedence_bin_int_op(op) - | BinOp(Float(op), _, _) => precedence_bin_float_op(op) - | BinOp(String(op), _, _) => precedence_bin_string_op(op) - | MultiHole(_) => DHDoc_common.precedence_max - | Parens(d) => precedence'(d) - }; -}; - -let mk_bin_bool_op = (op: Operators.op_bin_bool): DHDoc.t => - Doc.text(Operators.bool_op_to_string(op)); - -let mk_bin_int_op = (op: Operators.op_bin_int): DHDoc.t => - Doc.text(Operators.int_op_to_string(op)); - -let mk_bin_float_op = (op: Operators.op_bin_float): DHDoc.t => - Doc.text(Operators.float_op_to_string(op)); - -let mk_bin_string_op = (op: Operators.op_bin_string): DHDoc.t => - Doc.text(Operators.string_op_to_string(op)); - -let mk = - ( - ~settings: CoreSettings.Evaluation.t, - ~enforce_inline: bool, - ~selected_hole_instance: option(Id.t), - // The next four are used when drawing the stepper to track where we can annotate changes - ~previous_step: option((step, Id.t)), // The step that will be displayed above this one (an Id in included because it may have changed since the step was taken) - ~hidden_steps: list((step, Id.t)), // The hidden steps between the above and the current one (an Id in included because it may have changed since the step was taken) - ~chosen_step: option(step), // The step that will be taken next - ~next_steps: list((int, Id.t)), // The options for the next step, if it hasn't been chosen yet - ~env: ClosureEnvironment.t, - ~infomap: Statics.Map.t, - d: DHExp.t, - ) - : DHDoc.t => { - let precedence = - precedence( - ~show_casts=settings.show_casts, - ~show_function_bodies=settings.show_fn_bodies, - ); - let rec go = - ( - d: DHExp.t, - env: ClosureEnvironment.t, - enforce_inline: bool, - recent_subst: list(Var.t), - ) - : DHDoc.t => { - open Doc; - let recent_subst = - switch (previous_step) { - | Some((ps, id)) when id == DHExp.rep_id(d) => - switch (ps.knd, DHExp.term_of(ps.d_loc)) { - | (FunAp, Ap(_, d2, _)) => - switch (DHExp.term_of(d2)) { - | Fun(p, _, _, _) => DHPat.bound_vars(p) - | _ => [] - } - | (FunAp, _) => [] - | (LetBind, Let(p, _, _)) => DHPat.bound_vars(p) - | (LetBind, _) => [] - | (FixUnwrap, FixF(p, _, _)) => DHPat.bound_vars(p) - | (FixUnwrap, _) => [] - | (TypFunAp, _) // TODO: Could also do something here for type variable substitution like in FunAp? - | (InvalidStep, _) - | (VarLookup, _) - | (Seq, _) - | (FunClosure, _) - | (FixClosure, _) - | (DeferredAp, _) - | (UpdateTest, _) - | (CastTypAp, _) - | (CastAp, _) - | (BuiltinWrap, _) - | (UnOp(_), _) - | (BuiltinAp(_), _) - | (BinBoolOp(_), _) - | (BinIntOp(_), _) - | (BinFloatOp(_), _) - | (BinStringOp(_), _) - | (Projection, _) - | (ListCons, _) - | (ListConcat, _) - | (CaseApply, _) - | (CompleteClosure, _) - | (CompleteFilter, _) - | (Cast, _) - | (Conditional(_), _) - | (RemoveParens, _) - | (RemoveTypeAlias, _) => [] // Maybe this last one could count as a substitution? - } - | _ => recent_subst - }; - let go' = - ( - ~env=env, - ~enforce_inline=enforce_inline, - ~recent_subst=recent_subst, - d, - ) => { - go(d, env, enforce_inline, recent_subst); - }; - let parenthesize = (b, doc) => - if (b) { - hcats([ - DHDoc_common.Delim.open_Parenthesized, - doc |> DHDoc_common.pad_child(~enforce_inline), - DHDoc_common.Delim.close_Parenthesized, - ]); - } else { - doc(~enforce_inline); - }; - let go_case_rule = ((dp, dclause)): DHDoc.t => { - let hidden_clause = annot(DHAnnot.Collapsed, text(Unicode.ellipsis)); - let clause_doc = - settings.show_case_clauses - ? choices([ - hcats([space(), go'(~enforce_inline=true, dclause)]), - hcats([ - linebreak(), - indent_and_align(go'(~enforce_inline=false, dclause)), - ]), - ]) - : hcat(space(), hidden_clause); - hcats([ - DHDoc_common.Delim.bar_Rule, - DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline=false, - ), - DHDoc_common.Delim.arrow_Rule, - clause_doc, - ]); - }; - let go_case = (dscrut, drs) => - if (enforce_inline) { - fail(); - } else { - let scrut_doc = - choices([ - hcats([space(), go'(~enforce_inline=true, dscrut)]), - hcats([ - linebreak(), - indent_and_align(go'(~enforce_inline=false, dscrut)), - ]), - ]); - vseps( - List.concat([ - [hcat(DHDoc_common.Delim.open_Case, scrut_doc)], - drs |> List.map(go_case_rule), - [DHDoc_common.Delim.close_Case], - ]), - ); - }; - let go_formattable = (~enforce_inline) => go'(~enforce_inline); - let mk_left_associative_operands = (precedence_op, d1, d2) => ( - go_formattable(d1) |> parenthesize(precedence(d1) > precedence_op), - go_formattable(d2) |> parenthesize(precedence(d2) >= precedence_op), - ); - let mk_right_associative_operands = (precedence_op, d1, d2) => ( - go_formattable(d1) |> parenthesize(precedence(d1) >= precedence_op), - go_formattable(d2) |> parenthesize(precedence(d2) > precedence_op), - ); - let doc = { - switch (DHExp.term_of(d)) { - | Parens(d') => go'(d') - | Closure(env', d') => go'(d', ~env=env') - | Filter(flt, d') => - if (settings.show_stepper_filters) { - switch (flt) { - | Filter({pat, act}) => - let keyword = FilterAction.string_of_t(act); - let flt_doc = go_formattable(pat); - vseps([ - hcats([ - DHDoc_common.Delim.mk(keyword), - flt_doc - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline=false, - ), - DHDoc_common.Delim.mk("in"), - ]), - go'(d'), - ]); - | Residue(_, act) => - let keyword = FilterAction.string_of_t(act); - vseps([DHDoc_common.Delim.mk(keyword), go'(d')]); - }; - } else { - switch (flt) { - | Residue(_) => go'(d') - | Filter(_) => go'(d') - }; - } - - /* Hole expressions must appear within a closure in - the postprocessed result */ - | EmptyHole => - DHDoc_common.mk_EmptyHole( - ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, - env, - ) - | MultiHole(_ds) => - DHDoc_common.mk_EmptyHole( - ~selected=Some(DHExp.rep_id(d)) == selected_hole_instance, - env, - ) - | Invalid(t) => DHDoc_common.mk_InvalidText(t) - | Var(x) when settings.show_lookup_steps => text(x) - | Var(x) => - switch (ClosureEnvironment.lookup(env, x)) { - | None => text(x) - | Some(d') => - if (List.mem(x, recent_subst)) { - hcats([ - go'(~env=ClosureEnvironment.empty, d) - |> annot(DHAnnot.Substituted), - go'( - ~env=ClosureEnvironment.empty, - ~recent_subst=List.filter(u => u != x, recent_subst), - d', - ), - ]); - } else { - go'(~env=ClosureEnvironment.empty, d'); - } - } - | BuiltinFun(f) => text(f) - | Constructor(name, _) => DHDoc_common.mk_ConstructorLit(name) - | Bool(b) => DHDoc_common.mk_BoolLit(b) - | Int(n) => DHDoc_common.mk_IntLit(n) - | Float(f) => DHDoc_common.mk_FloatLit(f) - | String(s) => DHDoc_common.mk_StringLit(s) - | Undefined => DHDoc_common.mk_Undefined() - | Test(d) => DHDoc_common.mk_Test(go'(d)) - | Deferral(_) => text("_") - | Seq(d1, d2) => - let (doc1, doc2) = (go'(d1), go'(d2)); - DHDoc_common.mk_Sequence(doc1, doc2); - | ListLit(d_list) => - let ol = d_list |> List.map(d => go'(d)); - DHDoc_common.mk_ListLit(ol); - | Ap(Forward, d1, d2) => - let (doc1, doc2) = ( - go_formattable(d1) - |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), - go'(d2), - ); - DHDoc_common.mk_Ap(doc1, doc2); - | DeferredAp(d1, d2) => - let (doc1, doc2) = ( - go_formattable(d1) - |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), - go'(Tuple(d2) |> DHExp.fresh), - ); - DHDoc_common.mk_Ap(doc1, doc2); - | TypAp(d1, ty) => - let doc1 = go'(d1); - let doc2 = DHDoc_Typ.mk(~enforce_inline=true, ty); - DHDoc_common.mk_TypAp(doc1, doc2); - | Ap(Reverse, d1, d2) => - let (doc1, doc2) = ( - go_formattable(d1) - |> parenthesize(precedence(d1) > DHDoc_common.precedence_Ap), - go'(d2), - ); - DHDoc_common.mk_rev_Ap(doc2, doc1); - | UnOp(Meta(Unquote), d) => - DHDoc_common.mk_Ap( - text("$"), - go_formattable(d) - |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap), - ) - | UnOp(Bool(Not), d) => - DHDoc_common.mk_Ap( - text("!"), - go_formattable(d) - |> parenthesize(precedence(d) > DHDoc_common.precedence_Not), - ) - | UnOp(Int(Minus), d) => - DHDoc_common.mk_Ap( - text("-"), - go_formattable(d) - |> parenthesize(precedence(d) > DHDoc_common.precedence_Minus), - ) - | BinOp(Int(op), d1, d2) => - // TODO assumes all bin int ops are left associative - let (doc1, doc2) = - mk_left_associative_operands(precedence_bin_int_op(op), d1, d2); - hseps([doc1, mk_bin_int_op(op), doc2]); - | BinOp(Float(op), d1, d2) => - // TODO assumes all bin float ops are left associative - let (doc1, doc2) = - mk_left_associative_operands(precedence_bin_float_op(op), d1, d2); - hseps([doc1, mk_bin_float_op(op), doc2]); - | BinOp(String(op), d1, d2) => - // TODO assumes all bin string ops are left associative - let (doc1, doc2) = - mk_left_associative_operands(precedence_bin_string_op(op), d1, d2); - hseps([doc1, mk_bin_string_op(op), doc2]); - | Cons(d1, d2) => - let (doc1, doc2) = - mk_right_associative_operands(DHDoc_common.precedence_Cons, d1, d2); - DHDoc_common.mk_Cons(doc1, doc2); - | ListConcat(d1, d2) => - let (doc1, doc2) = - mk_right_associative_operands(DHDoc_common.precedence_Plus, d1, d2); - DHDoc_common.mk_ListConcat(doc1, doc2); - | BinOp(Bool(op), d1, d2) => - let (doc1, doc2) = - mk_right_associative_operands(precedence_bin_bool_op(op), d1, d2); - hseps([doc1, mk_bin_bool_op(op), doc2]); - | Tuple([]) => DHDoc_common.Delim.triv - | Tuple(ds) => DHDoc_common.mk_Tuple(ds |> List.map(d => go'(d))) - | Match(dscrut, drs) => go_case(dscrut, drs) - | TyAlias(_, _, d) => go'(d) - | Cast(d, t1, t2) when settings.show_casts => - // TODO[Matt]: Roll multiple casts into one cast - let doc = - go_formattable(d) - |> parenthesize(precedence(d) > DHDoc_common.precedence_Ap); - Doc.( - hcat( - doc, - annot( - DHAnnot.CastDecoration, - hcats([ - DHDoc_common.Delim.open_Cast, - DHDoc_Typ.mk(~enforce_inline=true, t1), - DHDoc_common.Delim.arrow_Cast, - DHDoc_Typ.mk(~enforce_inline=true, t2), - DHDoc_common.Delim.close_Cast, - ]), - ), - ) - ); - | Cast(d, _, _) => - let doc = go'(d); - doc; - | Let(dp, ddef, dbody) => - if (enforce_inline) { - fail(); - } else { - let bindings = DHPat.bound_vars(dp); - let def_doc = go_formattable(ddef); - vseps([ - hcats([ - DHDoc_common.Delim.mk("let"), - DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline, - ), - DHDoc_common.Delim.mk("="), - def_doc - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline=false, - ), - DHDoc_common.Delim.mk("in"), - ]), - go'( - ~enforce_inline=false, - ~env=ClosureEnvironment.without_keys(bindings, env), - ~recent_subst= - List.filter(x => !List.mem(x, bindings), recent_subst), - dbody, - ), - ]); - } - | FailedCast(d1, ty1, ty3) => - let d_doc = go'(d1); - let cast_decoration = - hcats([ - DHDoc_common.Delim.open_FailedCast, - hseps([ - DHDoc_Typ.mk(~enforce_inline=true, ty1), - DHDoc_common.Delim.arrow_FailedCast, - DHDoc_Typ.mk(~enforce_inline=true, ty3), - ]), - DHDoc_common.Delim.close_FailedCast, - ]) - |> annot(DHAnnot.FailedCastDecoration); - hcats([d_doc, cast_decoration]); - | DynamicErrorHole(d, err) => - let d_doc = go'(d); - let decoration = - Doc.text(InvalidOperationError.err_msg(err)) - |> annot(DHAnnot.OperationError(err)); - hcats([d_doc, decoration]); - | If(c, d1, d2) => - let c_doc = go_formattable(c); - let d1_doc = go_formattable(d1); - let d2_doc = go_formattable(d2); - hcats([ - DHDoc_common.Delim.mk("("), - DHDoc_common.Delim.mk("if"), - c_doc - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline=false, - ), - DHDoc_common.Delim.mk("then"), - d1_doc - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline=false, - ), - DHDoc_common.Delim.mk("else"), - d2_doc - |> DHDoc_common.pad_child( - ~inline_padding=(space(), empty()), - ~enforce_inline=false, - ), - DHDoc_common.Delim.mk(")"), - ]); - | Fun(dp, d, Some(env'), s) => - if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(dp); - let body_doc = - go_formattable( - Closure( - ClosureEnvironment.without_keys(Option.to_list(s), env'), - d, - ) - |> DHExp.fresh, - ~env= - ClosureEnvironment.without_keys( - DHPat.bound_vars(dp) @ Option.to_list(s), - env, - ), - ~recent_subst= - List.filter(x => !List.mem(x, bindings), recent_subst), - ); - hcats( - [ - DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline, - ), - ] - @ [ - DHDoc_common.Delim.arrow_Fun, - space(), - body_doc |> DHDoc_common.pad_child(~enforce_inline=false), - ], - ); - } else { - annot( - DHAnnot.Collapsed, - text( - switch (s) { - | None => "" - | Some(name) - when - !settings.show_fixpoints - && String.ends_with(~suffix="+", name) => - "<" ++ String.sub(name, 0, String.length(name) - 1) ++ ">" - | Some(name) => "<" ++ name ++ ">" - }, - ), - ); - } - | Fun(dp, dbody, None, s) => - if (settings.show_fn_bodies) { - let bindings = DHPat.bound_vars(dp); - let body_doc = - go_formattable( - dbody, - ~env=ClosureEnvironment.without_keys(bindings, env), - ~recent_subst= - List.filter(x => !List.mem(x, bindings), recent_subst), - ); - hcats( - [ - DHDoc_common.Delim.sym_Fun, - DHDoc_Pat.mk(~infomap, ~show_casts=settings.show_casts, dp) - |> DHDoc_common.pad_child( - ~inline_padding=(space(), space()), - ~enforce_inline, - ), - ] - @ [ - DHDoc_common.Delim.arrow_Fun, - space(), - body_doc |> DHDoc_common.pad_child(~enforce_inline), - ], - ); - } else { - switch (s) { - | None => annot(DHAnnot.Collapsed, text("")) - | Some(name) => annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")) - }; - } - | TypFun(_tpat, _dbody, s) => - /* same display as with Fun but with anon typfn in the nameless case. */ - let name = - switch (s) { - | None => "anon typfn" - | Some(name) - when - !settings.show_fixpoints - && String.ends_with(~suffix="+", name) => - String.sub(name, 0, String.length(name) - 1) - | Some(name) => name - }; - annot(DHAnnot.Collapsed, text("<" ++ name ++ ">")); - | FixF(dp, dbody, _) - when settings.show_fn_bodies && settings.show_fixpoints => - let doc_body = - go_formattable( - dbody, - ~env=ClosureEnvironment.without_keys(DHPat.bound_vars(dp), env), - ); - hcats( - [ - DHDoc_common.Delim.fix_FixF, - space(), - DHDoc_Pat.mk( - ~infomap, - dp, - ~show_casts=settings.show_casts, - ~enforce_inline=true, - ), - ] - @ [ - space(), - DHDoc_common.Delim.arrow_FixF, - space(), - doc_body |> DHDoc_common.pad_child(~enforce_inline), - ], - ); - | FixF(_, {term: Fun(_, _, _, Some(x)), _}, _) => - if (String.ends_with(~suffix="+", x)) { - annot( - DHAnnot.Collapsed, - text("<" ++ String.sub(x, 0, String.length(x) - 1) ++ ">"), - ); - } else { - annot(DHAnnot.Collapsed, text("<" ++ x ++ ">")); - } - | FixF(_, _, _) => annot(DHAnnot.Collapsed, text("")) - }; - }; - let steppable = - next_steps |> List.find_opt(((_, id)) => id == DHExp.rep_id(d)); - let stepped = - chosen_step - |> Option.map(x => DHExp.rep_id(x.d_loc) == DHExp.rep_id(d)) - |> Option.value(~default=false); - let substitution = - hidden_steps - |> List.find_opt(((step, id)) => - step.knd == VarLookup - // HACK[Matt]: to prevent substitutions hiding inside casts - && id == DHExp.rep_id(d) - ); - let doc = - switch (substitution) { - | Some((step, _)) => - switch (DHExp.term_of(step.d_loc)) { - | Var(v) when List.mem(v, recent_subst) => - hcats([text(v) |> annot(DHAnnot.Substituted), doc]) - | _ => doc - } - | None => doc - }; - let doc = - if (stepped) { - annot(DHAnnot.Stepped, doc); - } else { - switch (steppable) { - | Some((i, _)) => annot(DHAnnot.Steppable(i), doc) - | None => doc - }; - }; - doc; - }; - go(d, env, enforce_inline, []); -}; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re deleted file mode 100644 index 8996bd4b03..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Pat.re +++ /dev/null @@ -1,98 +0,0 @@ -open Pretty; -open Haz3lcore; - -let precedence = (dp: Pat.t) => - switch (DHPat.term_of(dp)) { - | EmptyHole - | MultiHole(_) - | Wild - | Invalid(_) - | Var(_) - | Int(_) - | Float(_) - | Bool(_) - | String(_) - | ListLit(_) - | Constructor(_) => DHDoc_common.precedence_const - | Tuple(_) => DHDoc_common.precedence_Comma - | Cons(_) => DHDoc_common.precedence_Cons - | Ap(_) => DHDoc_common.precedence_Ap - | Parens(_) => DHDoc_common.precedence_const - | Cast(_) => DHDoc_common.precedence_Ap - }; - -let rec mk = - ( - ~infomap: Statics.Map.t, - ~parenthesize=false, - ~show_casts, - ~enforce_inline: bool, - dp: Pat.t, - ) - : DHDoc.t => { - let mk' = mk(~enforce_inline, ~infomap, ~show_casts); - let mk_left_associative_operands = (precedence_op, dp1, dp2) => ( - mk'(~parenthesize=precedence(dp1) > precedence_op, dp1), - mk'(~parenthesize=precedence(dp2) >= precedence_op, dp2), - ); - let mk_right_associative_operands = (precedence_op, dp1, dp2) => ( - mk'(~parenthesize=precedence(dp1) >= precedence_op, dp1), - mk'(~parenthesize=precedence(dp2) > precedence_op, dp2), - ); - let doc = - switch (DHPat.term_of(dp)) { - | MultiHole(_) - | EmptyHole => DHDoc_common.mk_EmptyHole(ClosureEnvironment.empty) - | Invalid(t) => DHDoc_common.mk_InvalidText(t) - | Var(x) => Doc.text(x) - | Wild => DHDoc_common.Delim.wild - | Constructor(name, _) => DHDoc_common.mk_ConstructorLit(name) - | Int(n) => DHDoc_common.mk_IntLit(n) - | Float(f) => DHDoc_common.mk_FloatLit(f) - | Bool(b) => DHDoc_common.mk_BoolLit(b) - | String(s) => DHDoc_common.mk_StringLit(s) - | ListLit(d_list) => - let ol = List.map(mk', d_list); - DHDoc_common.mk_ListLit(ol); - | Cons(dp1, dp2) => - let (doc1, doc2) = - mk_right_associative_operands(DHDoc_common.precedence_Cons, dp1, dp2); - DHDoc_common.mk_Cons(doc1, doc2); - | Tuple([]) => DHDoc_common.Delim.triv - | Tuple(ds) => DHDoc_common.mk_Tuple(List.map(mk', ds)) - // TODO: Print type annotations - | Cast(dp, t1, t2) when show_casts => - Doc.hcats([ - mk'(dp), - Doc.annot( - DHAnnot.CastDecoration, - Doc.hcats([ - DHDoc_common.Delim.open_Cast, - DHDoc_Typ.mk(~enforce_inline=true, t1), - DHDoc_common.Delim.back_arrow_Cast, - DHDoc_Typ.mk(~enforce_inline=true, t2), - DHDoc_common.Delim.close_Cast, - ]), - ), - ]) - | Cast(dp, _, _) => mk'(~parenthesize, dp) - | Parens(dp) => - mk(~enforce_inline, ~parenthesize=true, ~infomap, ~show_casts, dp) - | Ap(dp1, dp2) => - let (doc1, doc2) = - mk_left_associative_operands(DHDoc_common.precedence_Ap, dp1, dp2); - DHDoc_common.mk_Ap(doc1, doc2); - }; - let doc = - switch (Statics.get_pat_error_at(infomap, DHPat.rep_id(dp))) { - | Some(_) => Doc.annot(DHAnnot.NonEmptyHole, doc) - | None => doc - }; - parenthesize - ? Doc.hcats([ - DHDoc_common.Delim.open_Parenthesized, - doc, - DHDoc_common.Delim.close_Parenthesized, - ]) - : doc; -}; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re deleted file mode 100644 index 143e36d3e3..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Typ.re +++ /dev/null @@ -1,12 +0,0 @@ -open Haz3lcore; -open Pretty; - -let promote_annot = - fun - | HTypAnnot.Term => DHAnnot.Term - | HTypAnnot.Step(n) => DHAnnot.Step(n) - | HTypAnnot.HoleLabel => DHAnnot.HoleLabel - | HTypAnnot.Delim => DHAnnot.Delim; -let promote = (d: HTypDoc.t): DHDoc.t => d |> Doc.map_annot(promote_annot); -let mk = (~enforce_inline: bool, ty: Typ.t): DHDoc.t => - ty |> HTypDoc.mk(~enforce_inline) |> promote; diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re b/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re deleted file mode 100644 index 9e9578d217..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_Util.re +++ /dev/null @@ -1,107 +0,0 @@ -open Haz3lcore; - -module Doc = Pretty.Doc; - -[@deriving sexp] -type t = Doc.t(DHAnnot.t); - -type formattable_child = (~enforce_inline: bool) => t; - -let precedence_const = DHDoc_common.precedence_const; -let precedence_Ap = DHDoc_common.precedence_Ap; -let precedence_Times = DHDoc_common.precedence_Times; -let precedence_Divide = DHDoc_common.precedence_Divide; -let precedence_Plus = DHDoc_common.precedence_Plus; -let precedence_Minus = DHDoc_common.precedence_Minus; -let precedence_Cons = DHDoc_common.precedence_Cons; -let precedence_Equals = DHDoc_common.precedence_Equals; -let precedence_LessThan = DHDoc_common.precedence_LessThan; -let precedence_GreaterThan = DHDoc_common.precedence_GreaterThan; -let precedence_And = DHDoc_common.precedence_And; -let precedence_Or = DHDoc_common.precedence_Or; -let precedence_Comma = DHDoc_common.precedence_Comma; -let precedence_max = DHDoc_common.precedence_max; - -let pad_child = - ( - ~inline_padding as (l, r)=(Doc.empty(), Doc.empty()), - ~enforce_inline: bool, - child: formattable_child, - ) - : t => { - let inline_choice = Doc.hcats([l, child(~enforce_inline=true), r]); - let para_choice = - Doc.( - hcats([ - linebreak(), - indent_and_align(child(~enforce_inline=false)), - linebreak(), - ]) - ); - enforce_inline ? inline_choice : Doc.choice(inline_choice, para_choice); -}; - -module Delim = { - let mk = (delim_text: string): t => - Doc.text(delim_text) |> Doc.annot(DHAnnot.Delim); - - let empty_hole = (_env: ClosureEnvironment.t): t => { - let lbl = "-"; - Doc.text(lbl) - |> Doc.annot(DHAnnot.HoleLabel) - |> Doc.annot(DHAnnot.Delim); - }; - - let list_nil = mk("[]"); - let triv = mk("()"); - let wild = mk("_"); - - let open_Parenthesized = mk("("); - let close_Parenthesized = mk(")"); - - let sym_Fun = mk("fun"); - let colon_Lam = mk(":"); - let open_Lam = mk(".{"); - let close_Lam = mk("}"); - - let fix_FixF = mk("fix"); - let colon_FixF = mk(":"); - let open_FixF = mk(".{"); - let close_FixF = mk("}"); - let open_Case = mk("case"); - let close_Case = mk("end"); - - let bar_Rule = mk("|"); - let arrow_Rule = mk("=>"); - - let open_Cast = mk("<"); - let arrow_Cast = mk(Unicode.castArrowSym); - let close_Cast = mk(">"); - - let open_FailedCast = open_Cast |> Doc.annot(DHAnnot.FailedCastDelim); - let arrow_FailedCast = - mk(Unicode.castArrowSym) |> Doc.annot(DHAnnot.FailedCastDelim); - let close_FailedCast = close_Cast |> Doc.annot(DHAnnot.FailedCastDelim); -}; - -let mk_EmptyHole = (~selected=false, env) => - Delim.empty_hole(env) |> Doc.annot(DHAnnot.EmptyHole(selected, env)); - -let mk_IntLit = n => Doc.text(string_of_int(n)); - -let mk_FloatLit = (f: float) => - switch (f < 0., Float.is_infinite(f), Float.is_nan(f)) { - | (false, true, _) => Doc.text("Inf") - /* TODO: NegInf is temporarily introduced until unary minus is introduced to Hazel */ - | (true, true, _) => Doc.text("NegInf") - | (_, _, true) => Doc.text("NaN") - | _ => Doc.text(string_of_float(f)) - }; - -let mk_BoolLit = b => Doc.text(string_of_bool(b)); - -let mk_Cons = (hd, tl) => Doc.(hcats([hd, text("::"), tl])); - -let mk_Pair = (doc1, doc2) => Doc.(hcats([doc1, text(", "), doc2])); - -let mk_Ap = (doc1, doc2) => Doc.hseps([doc1, doc2]); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re b/src/haz3lweb/view/dhcode/layout/DHDoc_common.re deleted file mode 100644 index 2f35d5f0ab..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.re +++ /dev/null @@ -1,141 +0,0 @@ -module Doc = Pretty.Doc; -open Haz3lcore; -open DHDoc; - -type formattable_child = (~enforce_inline: bool) => t; - -module P = Precedence; -let precedence_const = P.max; -let precedence_Ap = P.ap; -let precedence_Power = P.power; -let precedence_Not = P.not_; -let precedence_Times = P.mult; -let precedence_Divide = P.mult; -let precedence_Plus = P.plus; -let precedence_Minus = P.plus; -let precedence_Cons = P.cons; -let precedence_Equals = P.eqs; -let precedence_LessThan = P.eqs; -let precedence_GreaterThan = P.eqs; -let precedence_And = P.and_; -let precedence_Or = P.or_; -let precedence_Comma = P.comma; -let precedence_max = P.min; - -let pad_child = - ( - ~inline_padding as (l, r)=(Doc.empty(), Doc.empty()), - ~enforce_inline: bool, - child: formattable_child, - ) - : t => { - let inline_choice = Doc.hcats([l, child(~enforce_inline=true), r]); - let para_choice = - Doc.( - hcats([ - linebreak(), - indent_and_align(child(~enforce_inline=false)), - linebreak(), - ]) - ); - enforce_inline ? inline_choice : Doc.choice(inline_choice, para_choice); -}; - -module Delim = { - let mk = (delim_text: string): t => - Doc.text(delim_text) |> Doc.annot(DHAnnot.Delim); - - let empty_hole = (_env: ClosureEnvironment.t): t => { - let lbl = - //StringUtil.cat([string_of_int(u + 1), ":", string_of_int(i + 1)]); - "?"; - Doc.text(lbl) - |> Doc.annot(DHAnnot.HoleLabel) - |> Doc.annot(DHAnnot.Delim); - }; - - let list_nil = mk("[]"); - let triv = mk("()"); - let wild = mk("_"); - - let open_Parenthesized = mk("("); - let close_Parenthesized = mk(")"); - - let sym_Fun = mk("fun"); - let colon_Fun = mk(":"); - let arrow_Fun = mk("->"); - - let fix_FixF = mk("fix"); - - let arrow_FixF = mk("->"); - let colon_FixF = mk(":"); - - let open_Case = mk("case"); - let close_Case = mk("end"); - - let bar_Rule = mk("|"); - let arrow_Rule = mk("=>"); - - let open_Cast = mk("<"); - let arrow_Cast = mk(Unicode.castArrowSym); - let back_arrow_Cast = mk(Unicode.castBackArrowSym); - let close_Cast = mk(">"); - - let open_FailedCast = open_Cast |> Doc.annot(DHAnnot.FailedCastDelim); - let arrow_FailedCast = - mk(Unicode.castArrowSym) |> Doc.annot(DHAnnot.FailedCastDelim); - let close_FailedCast = close_Cast |> Doc.annot(DHAnnot.FailedCastDelim); -}; - -let mk_EmptyHole = (~selected=false, env: ClosureEnvironment.t) => - Delim.empty_hole(env) |> Doc.annot(DHAnnot.EmptyHole(selected, env)); - -let mk_InvalidText = t => Doc.text(t) |> Doc.annot(DHAnnot.Invalid); - -let mk_Sequence = (doc1, doc2) => Doc.(hcats([doc1, linebreak(), doc2])); - -let mk_IntLit = n => Doc.text(string_of_int(n)); - -let mk_StringLit = s => Doc.text(Form.string_quote(s)); - -let mk_Test = t => Doc.(hcats([text("Test"), t, text("End")])); - -let mk_FloatLit = (f: float) => - switch (f < 0., Float.is_infinite(f), Float.is_nan(f)) { - | (false, true, _) => Doc.text("Inf") /* TODO: NegInf is temporarily introduced until unary minus is introduced to Hazel */ - | (true, true, _) => Doc.text("NegInf") - | (_, _, true) => Doc.text("NaN") - | _ => Doc.text(string_of_float(f)) - }; - -let mk_BoolLit = b => Doc.text(string_of_bool(b)); - -let mk_ConstructorLit = Doc.text; - -let mk_Cons = (hd, tl) => Doc.(hcats([hd, text("::"), tl])); -let mk_ListConcat = (hd, tl) => Doc.(hcats([hd, text("@"), tl])); - -let mk_comma_seq = (ld, rd, l) => { - let rec mk_comma_seq_inner = l => { - switch (l) { - | [] => [] - | [hd] => [hd] - | [hd, ...tl] => Doc.([hd, text(", ")] @ mk_comma_seq_inner(tl)) - }; - }; - Doc.(hcats([text(ld)] @ mk_comma_seq_inner(l) @ [text(rd)])); -}; - -let mk_ListLit = l => mk_comma_seq("[", "]", l); - -let mk_Tuple = elts => mk_comma_seq("(", ")", elts); - -let mk_TypAp = (doc1, doc2) => - Doc.(hcats([doc1, text("@<"), doc2, text(">")])); - -let mk_Ap = (doc1, doc2) => - Doc.(hcats([doc1, text("("), doc2, text(")")])); - -let mk_rev_Ap = (doc1, doc2) => Doc.(hcats([doc1, text(" |> "), doc2])); - -let mk_Undefined = () => Doc.text("undefined"); diff --git a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei b/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei deleted file mode 100644 index aec422a020..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHDoc_common.rei +++ /dev/null @@ -1,99 +0,0 @@ -open Haz3lcore; - -type formattable_child = (~enforce_inline: bool) => DHDoc.t; - -let precedence_const: int; -let precedence_Ap: int; -let precedence_Times: int; -let precedence_Power: int; -let precedence_Divide: int; -let precedence_Plus: int; -let precedence_Minus: int; -let precedence_Not: int; -let precedence_Cons: int; -let precedence_Equals: int; -let precedence_LessThan: int; -let precedence_GreaterThan: int; -let precedence_And: int; -let precedence_Or: int; -let precedence_Comma: int; -let precedence_max: int; - -let pad_child: - ( - ~inline_padding: (Pretty.Doc.t(DHAnnot.t), Pretty.Doc.t(DHAnnot.t))=?, - ~enforce_inline: bool, - formattable_child - ) => - DHDoc.t; - -module Delim: { - let mk: string => DHDoc.t; - - let empty_hole: ClosureEnvironment.t => DHDoc.t; - - let list_nil: DHDoc.t; - let triv: DHDoc.t; - let wild: DHDoc.t; - - let open_Parenthesized: DHDoc.t; - let close_Parenthesized: DHDoc.t; - - let sym_Fun: DHDoc.t; - let colon_Fun: DHDoc.t; - let arrow_Fun: DHDoc.t; - - let fix_FixF: DHDoc.t; - let arrow_FixF: DHDoc.t; - let colon_FixF: DHDoc.t; - - let open_Case: DHDoc.t; - let close_Case: DHDoc.t; - - let bar_Rule: DHDoc.t; - let arrow_Rule: DHDoc.t; - - let open_Cast: DHDoc.t; - let arrow_Cast: DHDoc.t; - let back_arrow_Cast: DHDoc.t; - let close_Cast: DHDoc.t; - - let open_FailedCast: Pretty.Doc.t(DHAnnot.t); - let arrow_FailedCast: Pretty.Doc.t(DHAnnot.t); - let close_FailedCast: Pretty.Doc.t(DHAnnot.t); -}; - -let mk_EmptyHole: - (~selected: bool=?, ClosureEnvironment.t) => Pretty.Doc.t(DHAnnot.t); - -let mk_InvalidText: string => Pretty.Doc.t(DHAnnot.t); - -let mk_Sequence: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_Test: Pretty.Doc.t('a) => Pretty.Doc.t('a); - -let mk_IntLit: int => Pretty.Doc.t('a); - -let mk_FloatLit: float => Pretty.Doc.t('a); - -let mk_BoolLit: bool => Pretty.Doc.t('a); - -let mk_ConstructorLit: string => Pretty.Doc.t('a); - -let mk_StringLit: string => Pretty.Doc.t('a); - -let mk_Cons: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_ListConcat: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_ListLit: list(Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_Tuple: list(Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_TypAp: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_rev_Ap: (Pretty.Doc.t('a), Pretty.Doc.t('a)) => Pretty.Doc.t('a); - -let mk_Undefined: unit => Pretty.Doc.t('a); diff --git a/src/haz3lweb/view/dhcode/layout/DHLayout.re b/src/haz3lweb/view/dhcode/layout/DHLayout.re deleted file mode 100644 index 139dc52c36..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHLayout.re +++ /dev/null @@ -1,4 +0,0 @@ -open Pretty; - -[@deriving sexp] -type t = Layout.t(DHAnnot.t); diff --git a/src/haz3lweb/view/dhcode/layout/DHLayout.rei b/src/haz3lweb/view/dhcode/layout/DHLayout.rei deleted file mode 100644 index ae26af88da..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHLayout.rei +++ /dev/null @@ -1,2 +0,0 @@ -[@deriving sexp] -type t = Pretty.Layout.t(DHAnnot.t); diff --git a/src/haz3lweb/view/dhcode/layout/DHMeasuredLayout.re b/src/haz3lweb/view/dhcode/layout/DHMeasuredLayout.re deleted file mode 100644 index dd582ce455..0000000000 --- a/src/haz3lweb/view/dhcode/layout/DHMeasuredLayout.re +++ /dev/null @@ -1,7 +0,0 @@ -module MeasuredPosition = Pretty.MeasuredPosition; -module MeasuredLayout = Pretty.MeasuredLayout; - -[@deriving sexp] -type t = MeasuredLayout.t(DHAnnot.t); -type with_offset = MeasuredLayout.with_offset(DHAnnot.t); -include MeasuredLayout.Make(WeakMap); diff --git a/src/haz3lweb/view/dhcode/layout/HTypAnnot.re b/src/haz3lweb/view/dhcode/layout/HTypAnnot.re deleted file mode 100644 index a879bcafc7..0000000000 --- a/src/haz3lweb/view/dhcode/layout/HTypAnnot.re +++ /dev/null @@ -1,5 +0,0 @@ -type t = - | HoleLabel - | Delim - | Step(int) - | Term; diff --git a/src/haz3lweb/view/dhcode/layout/HTypAnnot.rei b/src/haz3lweb/view/dhcode/layout/HTypAnnot.rei deleted file mode 100644 index a879bcafc7..0000000000 --- a/src/haz3lweb/view/dhcode/layout/HTypAnnot.rei +++ /dev/null @@ -1,5 +0,0 @@ -type t = - | HoleLabel - | Delim - | Step(int) - | Term; diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.re b/src/haz3lweb/view/dhcode/layout/HTypDoc.re deleted file mode 100644 index 996d01f607..0000000000 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.re +++ /dev/null @@ -1,183 +0,0 @@ -open Util; -open Haz3lcore; -module Doc = Pretty.Doc; - -type t = Doc.t(HTypAnnot.t); - -type formattable_child = (~enforce_inline: bool) => t; - -let precedence_Prod = 1; -let precedence_Arrow = 2; -let precedence_Sum = 3; -let precedence_Ap = 4; -let precedence_Const = 5; - -let precedence = (ty: Typ.t): int => - switch (Typ.term_of(ty)) { - | Int - | Float - | Bool - | String - | Unknown(_) - | Var(_) - | Forall(_) - | Rec(_) - | Sum(_) => precedence_Sum - | List(_) => precedence_Const - | Prod(_) => precedence_Prod - | Arrow(_, _) => precedence_Arrow - | Parens(_) => precedence_Const - | Ap(_) => precedence_Ap - }; - -let pad_child = - ( - ~inline_padding as (l, r)=(Doc.empty(), Doc.empty()), - ~enforce_inline: bool, - child: formattable_child, - ) - : t => { - let inline_choice = Doc.hcats([l, child(~enforce_inline=true), r]); - let para_choice = - Doc.( - hcats([ - linebreak(), - indent_and_align(child(~enforce_inline)), - linebreak(), - ]) - ); - enforce_inline ? inline_choice : Doc.choice(inline_choice, para_choice); -}; - -let mk_delim = s => Doc.(annot(HTypAnnot.Delim, text(s))); - -let rec mk = (~parenthesize=false, ~enforce_inline: bool, ty: Typ.t): t => { - open Doc; - let mk' = mk(~enforce_inline); - let mk_right_associative_operands = (precedence_op, ty1, ty2) => ( - annot( - HTypAnnot.Step(0), - mk'(~parenthesize=precedence(ty1) <= precedence_op, ty1), - ), - annot( - HTypAnnot.Step(1), - mk'(~parenthesize=precedence(ty2) < precedence_op, ty2), - ), - ); - let (doc, parenthesize) = - switch (Typ.term_of(ty)) { - | Parens(ty) => (mk(~parenthesize=true, ~enforce_inline, ty), false) - | Unknown(_) => ( - annot(HTypAnnot.Delim, annot(HTypAnnot.HoleLabel, text("?"))), - parenthesize, - ) - | Int => (text("Int"), parenthesize) - | Float => (text("Float"), parenthesize) - | Bool => (text("Bool"), parenthesize) - | String => (text("String"), parenthesize) - | Var(name) => (text(name), parenthesize) - | List(ty) => ( - hcats([ - mk_delim("["), - ( - (~enforce_inline) => - annot(HTypAnnot.Step(0), mk(~enforce_inline, ty)) - ) - |> pad_child(~enforce_inline), - mk_delim("]"), - ]), - parenthesize, - ) - | Arrow(ty1, ty2) => - let (d1, d2) = - mk_right_associative_operands(precedence_Arrow, ty1, ty2); - ( - hcats([ - d1, - hcats([ - choices([linebreak(), space()]), - text(Unicode.typeArrowSym ++ " "), - ]), - d2, - ]), - parenthesize, - ); - | Prod([]) => (text("()"), parenthesize) - | Prod([head, ...tail]) => - let center = - [ - annot( - HTypAnnot.Step(0), - mk'(~parenthesize=precedence(head) <= precedence_Prod, head), - ), - ...List.mapi( - (i, ty) => - annot( - HTypAnnot.Step(i + 1), - mk'(~parenthesize=precedence(ty) <= precedence_Prod, ty), - ), - tail, - ), - ] - |> ListUtil.join( - hcats([text(","), choices([linebreak(), space()])]), - ) - |> hcats; - (center, true); - | Rec(name, ty) => ( - hcats([ - text("rec " ++ Type.tpat_view(name) ++ "->{"), - ( - (~enforce_inline) => - annot(HTypAnnot.Step(0), mk(~enforce_inline, ty)) - ) - |> pad_child(~enforce_inline), - mk_delim("}"), - ]), - parenthesize, - ) - | Forall(name, ty) => ( - hcats([ - text("forall " ++ Type.tpat_view(name) ++ "->{"), - ( - (~enforce_inline) => - annot(HTypAnnot.Step(0), mk(~enforce_inline, ty)) - ) - |> pad_child(~enforce_inline), - mk_delim("}"), - ]), - parenthesize, - ) - | Sum(sum_map) => - let center = - List.mapi( - (i, vr) => { - ConstructorMap.( - switch (vr) { - | Variant(ctr, _, None) => - annot(HTypAnnot.Step(i + 1), text(ctr)) - | Variant(ctr, _, Some(ty)) => - annot( - HTypAnnot.Step(i + 1), - hcats([text(ctr ++ "("), mk'(ty), text(")")]), - ) - | BadEntry(ty) => - annot(HTypAnnot.Step(i + 1), hcats([mk'(ty)])) - } - ) - }, - sum_map, - ) - |> ListUtil.join( - hcats([text(" +"), choices([linebreak(), space()])]), - ) - |> hcats; - (center, true); - | Ap(t1, t2) => ( - hcats([mk'(t1), text("("), mk'(t2), text(")")]), - parenthesize, - ) - }; - let doc = annot(HTypAnnot.Term, doc); - parenthesize ? Doc.hcats([mk_delim("("), doc, mk_delim(")")]) : doc; -}; diff --git a/src/haz3lweb/view/dhcode/layout/HTypDoc.rei b/src/haz3lweb/view/dhcode/layout/HTypDoc.rei deleted file mode 100644 index ab07b0e81e..0000000000 --- a/src/haz3lweb/view/dhcode/layout/HTypDoc.rei +++ /dev/null @@ -1,5 +0,0 @@ -open Haz3lcore; - -type t = Pretty.Doc.t(HTypAnnot.t); - -let mk: (~parenthesize: bool=?, ~enforce_inline: bool, Typ.t) => t; diff --git a/src/haz3lweb/www/style/cell.css b/src/haz3lweb/www/style/cell.css index e10c38a126..a5d0a3a2f4 100644 --- a/src/haz3lweb/www/style/cell.css +++ b/src/haz3lweb/www/style/cell.css @@ -27,7 +27,7 @@ position: relative; } -#main .code-container { +#main .code-editor { /* Only code in primary editor is selectable atm */ cursor: text; } @@ -39,21 +39,38 @@ min-width: 100%; } +.cell > * { + padding-left: 1em; + padding: 1em; + padding-left: 1.2em; +} + .cell-item { display: flex; flex-direction: column; gap: 1em; - padding-left: 1em; - padding: 1em; - padding-left: 1.2em; } -.cell.selected .cell-item:first-child { +.Scratch .cell { background-color: var(--cell-active); } +.Documentation .cell { + background-color: var(--cell-active); +} + +.cell:has(.code-editor.selected) { + background-color: var(--cell-active); +} + +.result .cell-item { + padding: 0em +} + .title-cell { padding-left: 1em; + padding-top: 0; + padding-bottom: 0; } .title-cell .title-text { @@ -62,10 +79,6 @@ color: var(--BR4); } -.cell-prompt { - padding: 1em; -} - /* DOCUMENTATION SLIDES */ .slide-img { diff --git a/src/haz3lweb/www/style/cursor-inspector.css b/src/haz3lweb/www/style/cursor-inspector.css index 5fdf6cfe96..a97c0c633b 100644 --- a/src/haz3lweb/www/style/cursor-inspector.css +++ b/src/haz3lweb/www/style/cursor-inspector.css @@ -172,6 +172,10 @@ color: var(--ci-status-error-text); } +#cursor-inspector .code { + position: relative; +} + #page > .context-inspector { position: absolute; @@ -237,4 +241,4 @@ .context-inspector .context-entry .seperator { color: var(--context-inspector-colon); -} +} \ No newline at end of file diff --git a/src/haz3lweb/www/style/dynamics.css b/src/haz3lweb/www/style/dynamics.css index 36881261c5..822f216481 100644 --- a/src/haz3lweb/www/style/dynamics.css +++ b/src/haz3lweb/www/style/dynamics.css @@ -13,10 +13,6 @@ padding-left: 1.2em; } -.selected .cell-result { - background-color: var(--cell-result); -} - .cell-result .status { position: relative; display: flex; @@ -83,10 +79,6 @@ font-family: var(--code-font); } -.cell.selected + .cell-item { - border-left: 1px solid var(--cell-selected-accent); -} - .result { width: 100%; } @@ -221,17 +213,29 @@ content: "←"; } -.steppable, -.steppable *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { - outline: 1px var(--step-hole-color); - background-color: var(--shard-selected); +.tile-next-step path, +.tile-next-step path *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { + border: 1px var(--G1); + fill: var(--G1); cursor: pointer; } -.stepped, -.stepped *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { - border: 1px var(--step-hole-color); - background-color: var(--Y1); +.tile-taken-step path, +.tile-taken-step path *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { + border: 1px var(--BR1); + fill: var(--BR1); +} + +.child-line.Exp.next-step-line { + stroke: var(--G2); +} + +.child-line.Exp.taken-step-line { + stroke: var(--BR1); +} + +.taken-step-line { + stroke: var(--BR1); } .substituted { @@ -303,3 +307,34 @@ transform: scale(100%); cursor: not-allowed; } + +.tile-next-step .tile-path.Exp.indicated { + fill: var(--G1) +} + +.tile-taken-step .tile-path.Exp.indicated { + fill: var(--BR1) +} + +svg.tile-next-step { + pointer-events: all; + cursor: pointer; + z-index: var(--test-result-z); + filter: drop-shadow(1px 1px var(--G2)); +} + +svg.tile-next-step-top { + pointer-events: all; + cursor: pointer; + visibility: hidden; + z-index: var(--stepper-interactive-z); + filter: drop-shadow(1px 1px var(--G2)); +} + +svg.tile-taken-step { + filter: drop-shadow(1px 1px var(--BR1)); +} + +.cell-result .code { + pointer-events: none; +} \ No newline at end of file diff --git a/src/haz3lweb/www/style/exercise-mode.css b/src/haz3lweb/www/style/exercise-mode.css index 5eb8e2d74c..1dac832e86 100644 --- a/src/haz3lweb/www/style/exercise-mode.css +++ b/src/haz3lweb/www/style/exercise-mode.css @@ -29,11 +29,11 @@ text-transform: uppercase; } -#main.Exercises .cell.deselected { +#main.Exercises .cell.unlocked { border-left: 1px solid var(--cell-exercises-border); } -#main.Exercises .cell.selected { +#main.Exercises .cell.unlocked:has(.code-editor.selected) { border-left: 1px solid var(--cell-selected-accent); background-color: var(--cell-active); } diff --git a/src/haz3lweb/www/style/projectors.css b/src/haz3lweb/www/style/projectors.css index c6b2c1a833..8d187f01a0 100644 --- a/src/haz3lweb/www/style/projectors.css +++ b/src/haz3lweb/www/style/projectors.css @@ -49,6 +49,11 @@ } .projector.fold { cursor: pointer; + font-family: var(--code-font); +} + +.result .projector.fold { + cursor: default; } /* PROJECTOR: INFO */ diff --git a/src/haz3lweb/www/style/variables.css b/src/haz3lweb/www/style/variables.css index 96c6225816..143829787d 100644 --- a/src/haz3lweb/www/style/variables.css +++ b/src/haz3lweb/www/style/variables.css @@ -209,6 +209,7 @@ /* ABOVE CODE LEVEL */ --backpack-targets-z: 11; + --stepper-interactive-z: 15; --caret-z: 20; /* TOP LEVEL UI */ diff --git a/src/util/BonsaiUtil.re b/src/util/BonsaiUtil.re index 127172ce21..a5b9ce4057 100644 --- a/src/util/BonsaiUtil.re +++ b/src/util/BonsaiUtil.re @@ -1,6 +1,7 @@ open Core; open Bonsai; open Bonsai.Let_syntax; +open Js_of_ocaml; module Alarm = { module Action = { @@ -40,3 +41,64 @@ module Alarm = { ); }; }; + +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/Calc.re b/src/util/Calc.re new file mode 100644 index 0000000000..623bf3ee8a --- /dev/null +++ b/src/util/Calc.re @@ -0,0 +1,106 @@ +/* + A helper module for making things that look incremental (but aren't + because we haven't integrated incrementality yet). Eventually this module + will hopefully be made redundant by the Bonsai tree. + */ + +// ================================================================================ +// t('a) is the basic datatype that stores a value and whether it has been updated + +[@deriving (show({with_path: false}), sexp, yojson)] +type t('a) = + | OldValue('a) + | NewValue('a); + +let combine = (x: t('a), y: t('b)): t(('a, 'b)) => + switch (x, y) { + | (OldValue(x), OldValue(y)) => OldValue((x, y)) + | (OldValue(x) | NewValue(x), OldValue(y) | NewValue(y)) => + NewValue((x, y)) + }; + +let make_old = (x: t('a)): t('a) => + switch (x) { + | OldValue(x) + | NewValue(x) => OldValue(x) + }; + +let get_value = (x: t('a)): 'a => + switch (x) { + | OldValue(x) + | NewValue(x) => x + }; + +let map_if_new = (f: 'a => 'a, x: t('a)): t('a) => + switch (x) { + | OldValue(x) => OldValue(x) + | NewValue(x) => OldValue(f(x)) + }; + +let is_new = (x: t('a)): bool => + switch (x) { + | OldValue(_) => false + | NewValue(_) => true + }; + +// ================================================================================ +// saved('a) is used to store a value that has been calculated in the model +[@deriving (show({with_path: false}), sexp, yojson)] +type saved('a) = + | Pending + | Calculated('a); + +let get_saved = (default, x: saved('a)): 'a => + switch (x) { + | Pending => default + | Calculated(x) => x + }; + +let map_saved = (f: 'a => 'b, x: saved('a)): saved('b) => + switch (x) { + | Pending => Pending + | Calculated(x) => Calculated(f(x)) + }; + +/* Using update, we can make a value of saved('a) that recalculates whenever + the value of t('a) changes. */ +let update = (x: t('a), f: 'a => 'b, y: saved('b)): t('b) => + switch (y, x) { + | (Pending, OldValue(x)) => NewValue(f(x)) + | (Pending | Calculated(_), NewValue(x)) => NewValue(f(x)) + | (Calculated(y), OldValue(_)) => OldValue(y) + }; + +/* Using set, we can compare some value to the previously saved value, and create + a new t('a) that indicates whether the value has changed. */ +let set = (~eq: ('a, 'a) => bool=(==), x: 'a, y: saved('a)) => + switch (y) { + | Pending => NewValue(x) + | Calculated(x') when eq(x, x') => OldValue(x) + | Calculated(_) => NewValue(x) + }; + +/* Save takes a value of t('a) that has been recalculated and stores it in a + saved so it can be put back in the model */ +let save = (x: t('a)): saved('a) => + switch (x) { + | OldValue(x) + | NewValue(x) => Calculated(x) + }; + +// ================================================================================ +// Helper functions: + +let to_option = (x: t(option('a))): option(t('a)) => { + switch (x) { + | OldValue(Some(x)) => Some(OldValue(x)) + | NewValue(Some(x)) => Some(NewValue(x)) + | OldValue(None) => None + | NewValue(None) => None + }; +}; + +module Syntax = { + let (let.calc) = update; + let (and.calc) = combine; +}; diff --git a/src/util/JsUtil.re b/src/util/JsUtil.re index bd8388b7ad..36890d518d 100644 --- a/src/util/JsUtil.re +++ b/src/util/JsUtil.re @@ -23,6 +23,22 @@ let get_elem_by_selector = selector => { ); }; +let get_child_with_class = (element: Js.t(Dom_html.element), className) => { + let rec loop = (sibling: Js.t(Dom_html.element)) => + if (Js.to_bool(sibling##.classList##contains(Js.string(className)))) { + Some(sibling); + } else { + loop( + Js.Opt.get(sibling##.nextSibling, () => failwith("no sibling")) + |> Js.Unsafe.coerce, + ); + }; + loop( + Js.Opt.get(element##.firstChild, () => failwith("no child")) + |> Js.Unsafe.coerce, + ); +}; + let date_now = () => { [%js new Js.date_now]; }; diff --git a/src/util/ListUtil.re b/src/util/ListUtil.re index 8481df4f0a..1e7e87a1af 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -540,3 +540,54 @@ let rec unzip = (lst: list(('a, 'b))): (list('a), list('b)) => { ([a, ..._as], [b, ...bs]); }; }; + +let cross = (xs, ys) => + List.concat(List.map(x => List.map(y => (x, y), ys), xs)); + +let rec intersperse = (sep, xs) => + switch (xs) { + | [] => [] + | [x] => [x] + | [x, ...xs] => [x, sep, ...intersperse(sep, xs)] + }; + +let rec flat_intersperse = (sep, xss) => + switch (xss) { + | [] => [] + | [xs] => xs + | [xs, ...xss] => xs @ [sep, ...flat_intersperse(sep, xss)] + }; + +let rec map_last_only = (f, xs) => + switch (xs) { + | [] => [] + | [x] => [f(x)] + | [x, ...xs] => [x, ...map_last_only(f, xs)] + }; + +let rec split_last = (xs: list('x)): (list('x), 'x) => + switch (xs) { + | [] => failwith("ListUtil.split_last") + | [x] => ([], x) + | [x, ...xs] => + let (prefix, last) = split_last(xs); + ([x, ...prefix], last); + }; + +let minimum = (f: 'a => int, xs: list('a)): option('a) => + switch (xs) { + | [] => None + | [x, ...xs] => + let rec loop = (best: 'a, best_f: int, xs: list('a)): option('a) => + switch (xs) { + | [] => Some(best) + | [x, ...xs] => + let f_x = f(x); + if (f_x < best_f) { + loop(x, f_x, xs); + } else { + loop(best, best_f, xs); + }; + }; + loop(x, f(x), xs); + }; diff --git a/src/util/Result.re b/src/util/Result.re index 27a24a3aa0..056487d829 100644 --- a/src/util/Result.re +++ b/src/util/Result.re @@ -4,3 +4,31 @@ module Syntax = { let ( let* ) = (result, f) => bind(~f, result); let (let+) = (result, f) => map(~f, result); }; + +module Serialization = { + [@deriving (show, sexp, yojson)] + type persistent('a, 'b) = + | Ok('a) + | Error('b); + + let to_persistent = (result: t('a, 'b)): persistent('a, 'b) => + switch (result) { + | Ok(a) => Ok(a) + | Error(b) => Error(b) + }; + + let of_persistent = (result: persistent('a, 'b)): t('a, 'b) => + switch (result) { + | Ok(a) => Ok(a) + | Error(b) => Error(b) + }; +}; + +let pp = (a, b, c, x) => + x |> Serialization.to_persistent |> Serialization.pp_persistent(a, b, c); + +let t_of_yojson = (a, b, x) => + x |> Serialization.persistent_of_yojson(a, b) |> Serialization.of_persistent; + +let yojson_of_t = (a, b, x) => + x |> Serialization.to_persistent |> Serialization.yojson_of_persistent(a, b); diff --git a/src/util/Util.re b/src/util/Util.re index 2c7f084100..cc5b2f5b21 100644 --- a/src/util/Util.re +++ b/src/util/Util.re @@ -20,6 +20,7 @@ module JsUtil = JsUtil; module Key = Key; module Os = Os; module Point = Point; +module Calc = Calc; // Used by [@deriving sexp, yojson)] include Sexplib.Std; diff --git a/src/util/Web.re b/src/util/Web.re index 358b1327d3..25bfb380b9 100644 --- a/src/util/Web.re +++ b/src/util/Web.re @@ -1,6 +1,8 @@ open Sexplib.Std; open Ppx_yojson_conv_lib.Yojson_conv; open Virtual_dom.Vdom; + +module Node = Node; open Node; open JsUtil; open Js_of_ocaml; diff --git a/test/Test_Evaluator.re b/test/Test_Evaluator.re index 37fcaba764..24ff5af4c7 100644 --- a/test/Test_Evaluator.re +++ b/test/Test_Evaluator.re @@ -7,8 +7,8 @@ let evaluation_test = (msg, expected, unevaluated) => dhexp_typ, msg, expected, - Evaluator.Result.unbox( - snd(Evaluator.evaluate(Builtins.env_init, {d: unevaluated})), + ProgramResult.Result.unbox( + snd(Evaluator.evaluate'(Builtins.env_init, {d: unevaluated})), ), );