diff --git a/Makefile b/Makefile index c1f5943d07..773e900d38 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/src/haz3lcore/dynamics/Casts.re b/src/haz3lcore/dynamics/Casts.re index 170d057e76..90427cbeb0 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(DHExp.Cast(inner_cast, t2_grounded, t2) |> DHExp.fresh); + Some( + DHExp.Cast(inner_cast, t2_grounded |> DHExp.replace_all_ids_typ, t2) + |> DHExp.fresh, + ); | (NotGroundOrHole(t1_grounded), Hole) => /* ITGround rule */ Some( - DHExp.Cast(Cast(d1, t1, t1_grounded) |> DHExp.fresh, t1_grounded, t2) + DHExp.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..65dc00a533 100644 --- a/src/haz3lcore/dynamics/DHExp.re +++ b/src/haz3lcore/dynamics/DHExp.re @@ -14,15 +14,17 @@ 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, +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), ); +}; // TODO: make this function emit a map of changes let repair_ids = @@ -34,6 +36,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); + }, _, ); 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 fb877accd7..05d255cc8e 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 = @@ -132,7 +113,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); @@ -144,3 +125,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 f25f25603f..7d0a37e15f 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 = @@ -201,7 +380,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; @@ -211,221 +391,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 a54c9d18d8..a68b2add46 100644 --- a/src/haz3lcore/dynamics/Transition.re +++ b/src/haz3lcore/dynamics/Transition.re @@ -809,3 +809,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 084a252de4..147482613b 100644 --- a/src/haz3lcore/lang/term/IdTagged.re +++ b/src/haz3lcore/lang/term/IdTagged.re @@ -17,6 +17,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 18d6e66284..c599af61c7 100644 --- a/src/haz3lcore/lang/term/Typ.re +++ b/src/haz3lcore/lang/term/Typ.re @@ -34,6 +34,15 @@ 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 hole = (tms: list(TermBase.Any.t)) => 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..ba15206f41 --- /dev/null +++ b/src/haz3lcore/pretty/ExpToSegment.re @@ -0,0 +1,1112 @@ +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="⏎") => false + | _ when String.starts_with(s2, ~prefix="⏎") => false + | _ + when + String.ends_with(s1, ~suffix=")") + && 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); + | 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, + [ + List.flatten( + List.map2( + (id, e) => [mk_form("comma_exp", id, [])] @ e, + ids, + es, + ), + ), + ], + ), + ]; + | 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 |> fold_if(settings.fold_cast_types)); + | 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) = IdTagged.unwrap(tpat); + switch (term) { + // Indivisible forms dont' change + | Var(_) + | Invalid(_) + | EmptyHole => tpat + + // Other forms + | MultiHole(xs) => TPat.MultiHole(List.map(parenthesize_any, xs)) |> rewrap + }; +} + +and parenthesize_rul = (rul: Rul.t): Rul.t => { + let (term, rewrap) = IdTagged.unwrap(rul); + switch (term) { + // Indivisible forms dont' change + | Invalid(_) => rul + + // Other forms + | Rules(e, ps) => + Rul.Rules( + parenthesize(e), + List.map(((p, e)) => (parenthesize_pat(p), parenthesize(e)), ps), + ) + |> rewrap + | Hole(xs) => Rul.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 f2bc13d113..9e9e329f58 100644 --- a/src/haz3lcore/prog/CachedStatics.re +++ b/src/haz3lcore/prog/CachedStatics.re @@ -1,35 +1,47 @@ 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: UExp.{ids: [Id.invalid], copied: false, term: Tuple([])}, + elaborated: UExp.{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 95% rename from src/haz3lcore/dynamics/Elaborator.re rename to src/haz3lcore/statics/Elaborator.re index c1f3aa12d7..d752fe089b 100644 --- a/src/haz3lcore/dynamics/Elaborator.re +++ b/src/haz3lcore/statics/Elaborator.re @@ -23,11 +23,11 @@ let fresh_cast = (d: DHExp.t, t1: Typ.t, t2: Typ.t): DHExp.t => { ? d : { let d' = - DHExp.Cast(d, t1, Typ.temp(Unknown(Internal))) - |> DHExp.fresh + Exp.Cast(d, t1, Typ.temp(Unknown(Internal))) + |> IdTagged.fresh_deterministic(DHExp.rep_id(d)) |> Casts.transition_multiple; DHExp.Cast(d', Typ.temp(Unknown(Internal)), t2) - |> DHExp.fresh + |> 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 = @@ -159,14 +159,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)) { @@ -261,7 +263,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); @@ -281,7 +283,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(Typ.Unknown(Internal))), ) | Let(p, def, body) => @@ -310,11 +314,12 @@ let rec elaborate = (m: Statics.Map.t, uexp: UExp.t): (DHExp.t, Typ.t) => { |> 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 = + Exp.FixF(p, fresh_cast(def, ty2, ty1), None) + |> IdTagged.fresh_deterministic(DHExp.rep_id(uexp)); Exp.Let(p, fixf, body) |> rewrap |> cast_from(ty); }; | FixF(p, e, env) => @@ -571,5 +576,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 673af0bb89..71c8043f99 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 5a85dbecd9..95c8cfdc86 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 aca1ce0389..fc5011b567 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 0493150865..4a98d237ca 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,186 @@ module Exp = { | Constructor(_) => None }; }; + + 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 |> 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 f0585955c6..432209da0b 100644 --- a/src/haz3lcore/statics/TermBase.re +++ b/src/haz3lcore/statics/TermBase.re @@ -325,7 +325,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); @@ -1020,6 +1021,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; } = { @@ -1097,6 +1099,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, Exp.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 cd05476fd9..819ae28bf3 100644 --- a/src/haz3lcore/zipper/Editor.re +++ b/src/haz3lcore/zipper/Editor.re @@ -1,43 +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: UExp.{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, @@ -62,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), @@ -78,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), }; }; @@ -161,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 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 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 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 ff59e48f55..0763c7eb11 100644 --- a/src/haz3lcore/zipper/EditorUtil.re +++ b/src/haz3lcore/zipper/EditorUtil.re @@ -48,3 +48,21 @@ let rec append_exp = (e1: Exp.t, e2: Exp.t): Exp.t => { } ); }; + +let wrap_filter = (act: FilterAction.action, term: UExp.t): UExp.t => + Exp.{ + term: + Exp.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..c9223c35e7 100644 --- a/src/haz3lcore/zipper/Printer.re +++ b/src/haz3lcore/zipper/Printer.re @@ -78,13 +78,13 @@ 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"); 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..39de43e39e 100644 --- a/src/haz3lcore/zipper/projectors/FoldProj.re +++ b/src/haz3lcore/zipper/projectors/FoldProj.re @@ -3,20 +3,24 @@ open ProjectorBase; open Virtual_dom.Vdom; open Node; +[@deriving (show({with_path: false}), sexp, yojson)] +type t = {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 b5e7dfc76d..0000000000 --- a/src/haz3lschool/Exercise.re +++ /dev/null @@ -1,946 +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 => - Exp.{ - term: - Exp.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 7b5512fc10..0000000000 --- a/src/haz3lweb/Editors.re +++ /dev/null @@ -1,171 +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 - }; - print_endline("action: " ++ Action.show(a)); - 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 deleted file mode 100644 index 9c9f709fa9..0000000000 --- a/src/haz3lweb/Export.re +++ /dev/null @@ -1,66 +0,0 @@ -open Util; - -[@deriving (show({with_path: false}), sexp, yojson)] -type all = { - settings: string, - explainThisModel: string, - scratch: string, - exercise: string, - documentation: string, - log: string, -}; - -// fallback for saved state prior to release of lang doc in 490F22 -[@deriving (show({with_path: false}), sexp, yojson)] -type all_f22 = { - settings: string, - scratch: string, - exercise: string, - 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 exercise = - Store.Exercise.export( - ~settings=settings_obj.core, - ~specs=ExerciseSettings.exercises, - ~instructor_mode, - ); - {settings, explainThisModel, scratch, documentation, exercise, log}; -}; - -let export_all = (~instructor_mode, ~log) => { - mk_all(~instructor_mode, ~log) |> yojson_of_all; -}; - -let import_all = (data, ~specs) => { - let all = - try(data |> Yojson.Safe.from_string |> all_of_yojson) { - | _ => - let all_f22 = data |> Yojson.Safe.from_string |> all_f22_of_yojson; - { - settings: all_f22.settings, - scratch: all_f22.scratch, - documentation: "", - exercise: all_f22.exercise, - log: all_f22.log, - explainThisModel: "", - }; - }; - let settings = Store.Settings.import(all.settings); - Store.ExplainThisModel.import(all.explainThisModel); - let instructor_mode = settings.instructor_mode; - Store.Scratch.import(~settings=settings.core, all.scratch); - Store.Exercise.import( - ~settings=settings.core, - all.exercise, - ~specs, - ~instructor_mode, - ); - Log.import(all.log); -}; 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 deleted file mode 100644 index f0501a66a4..0000000000 --- a/src/haz3lweb/Keyboard.re +++ /dev/null @@ -1,341 +0,0 @@ -open Haz3lcore; -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" - | PC => "ctrl" - }; -}; - -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(Update.t) => { - let now = (a: Action.t): option(UpdateAction.t) => - Some(PerformAction(a)); - switch (k) { - | {key: U(key), _} => - /* Keu-UPpEvents: - NOTE: Remember that since there is a keyup for every - 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)))) - | (Up, "ArrowRight") => now(Move(Local(Right(ByChar)))) - | (Up, "ArrowUp") => now(Move(Local(Up))) - | (Up, "ArrowDown") => now(Move(Local(Down))) - | (Up, "Home") => now(Move(Extreme(Left(ByToken)))) - | (Up, "End") => now(Move(Extreme(Right(ByToken)))) - | (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))))) - | (Down, "ArrowRight") => now(Select(Resize(Local(Right(ByToken))))) - | (Down, "ArrowUp") => now(Select(Resize(Local(Up)))) - | (Down, "ArrowDown") => now(Select(Resize(Local(Down)))) - | (Down, "Home") => now(Select(Resize(Extreme(Left(ByToken))))) - | (Down, "End") => now(Select(Resize(Extreme(Right(ByToken))))) - | (_, "Enter") => now(Insert(Form.linebreak)) - | _ when String.length(key) == 1 => - /* Note: length==1 prevent specials like - * SHIFT from being captured here */ - now(Insert(key)) - | _ => None - } - | {key: D(key), sys: Mac, shift: Down, meta: Down, ctrl: Up, alt: Up} => - switch (key) { - | "ArrowLeft" => now(Select(Resize(Extreme(Left(ByToken))))) - | "ArrowRight" => now(Select(Resize(Extreme(Right(ByToken))))) - | "ArrowUp" => now(Select(Resize(Extreme(Up)))) - | "ArrowDown" => now(Select(Resize(Extreme(Down)))) - | _ => None - } - | {key: D(key), sys: PC, shift: Down, meta: Up, ctrl: Down, alt: Up} => - switch (key) { - | "ArrowLeft" => now(Select(Resize(Local(Left(ByToken))))) - | "ArrowRight" => now(Select(Resize(Local(Right(ByToken))))) - | "ArrowUp" => now(Select(Resize(Local(Up)))) - | "ArrowDown" => now(Select(Resize(Local(Down)))) - | "Home" => now(Select(Resize(Extreme(Up)))) - | "End" => now(Select(Resize(Extreme(Down)))) - | _ => None - } - | {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)) - | "a" => now(Select(All)) - | "/" => Some(PerformAction(Buffer(Set(TyDi)))) - | "ArrowLeft" => now(Move(Extreme(Left(ByToken)))) - | "ArrowRight" => now(Move(Extreme(Right(ByToken)))) - | "ArrowUp" => now(Move(Extreme(Up))) - | "ArrowDown" => now(Move(Extreme(Down))) - | _ => None - } - | {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)) - | "a" => now(Select(All)) - | "/" => Some(PerformAction(Buffer(Set(TyDi)))) - | "ArrowLeft" => now(Move(Local(Left(ByToken)))) - | "ArrowRight" => now(Move(Local(Right(ByToken)))) - | "Home" => now(Move(Extreme(Up))) - | "End" => now(Move(Extreme(Down))) - | _ => None - } - | {key: D(key), sys: Mac, shift: Up, meta: Up, ctrl: Down, alt: Up} => - switch (key) { - | "a" => now(Move(Extreme(Left(ByToken)))) - | "e" => now(Move(Extreme(Right(ByToken)))) - | _ => None - } - | {key: D("f"), sys: PC, shift: Up, meta: Up, ctrl: Up, alt: Down} => - Some(PerformAction(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)))) - | {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 - } - | _ => None - }; -}; diff --git a/src/haz3lweb/Main.re b/src/haz3lweb/Main.re index cf0269bf45..c244632e0c 100644 --- a/src/haz3lweb/Main.re +++ b/src/haz3lweb/Main.re @@ -36,59 +36,81 @@ let restart_caret_animation = () => | _ => () }; -let apply = (model, action, state, ~schedule_action): Model.t => { +let apply = + ( + model: Page.Model.t, + action: Page.Update.t, + _state: unit, + ~schedule_action, + ) + : Page.Model.t => { restart_caret_animation(); - if (UpdateAction.is_edit(action)) { - last_edit_action := JsUtil.timestamp(); - edit_action_applied := true; - }; - if (Update.should_scroll_to_caret(action)) { - scroll_to_caret := true; - }; - last_edit_action := JsUtil.timestamp(); - switch ( - try({ - let new_model = Update.apply(model, action, state, ~schedule_action); - Log.update(action); - new_model; - }) { + + /* 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, + ) + ) { | 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 |> 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) { + last_edit_action := JsUtil.timestamp(); + edit_action_applied := true; + }; + if (updated.scroll_active) { + scroll_to_caret := true; }; + model'; }; module App = { - module Model = Model; - module Action = Update; - module State = State; + module Model = Page.Model; + module Action = Page.Update; + module State = { + type t = unit; + let init = () => (); + }; - let on_startup = (~schedule_action, m: Model.t) => { + let on_startup = (~schedule_action, _: Model.t) => { let _ = observe_font_specimen("font-specimen", fm => - schedule_action(Haz3lweb.Update.SetMeta(FontMetrics(fm))) + schedule_action(Haz3lweb.Page.Update.Globals(SetFontMetrics(fm))) ); - NinjaKeys.initialize(NinjaKeys.options(schedule_action)); + NinjaKeys.initialize(Shortcut.options(schedule_action)); JsUtil.focus_clipboard_shim(); + Js.Unsafe.set( + Js.Unsafe.global##._Error, + "stackTraceLimit", + Js.number_of_float(infinity), + ); + /* initialize state. */ let state = State.init(); - /* Initial evaluation on a worker */ - Update.schedule_evaluation(~schedule_action, m); + schedule_action(Start); Os.is_mac := Dom_html.window##.navigator##.platform##toUpperCase##indexOf( @@ -99,11 +121,7 @@ module App = { }; let create = - ( - model: Incr.t(Haz3lweb.Model.t), - ~old_model as _: Incr.t(Haz3lweb.Model.t), - ~inject, - ) => { + (model: Incr.t(Model.t), ~old_model as _: Incr.t(Model.t), ~inject) => { open Incr.Let_syntax; let%map model = model; /* Note: mapping over the old_model here may @@ -111,7 +129,7 @@ module App = { Component.create( ~apply_action=apply(model), model, - Haz3lweb.Page.view(~inject, model), + Haz3lweb.Page.View.view(~get_log_and=Log.get_and, ~inject, model), ~on_display=(_, ~schedule_action) => { if (edit_action_applied^ && JsUtil.timestamp() @@ -120,7 +138,7 @@ module App = { has been applied for 1 second, save the model. */ edit_action_applied := false; print_endline("Saving..."); - schedule_action(Update.Save); + schedule_action(Page.Update.Save); }; if (scroll_to_caret.contents) { scroll_to_caret := false; @@ -138,6 +156,6 @@ switch (JsUtil.Fragment.get_current()) { (module App), ~debug=false, ~bind_to_element_with_id="container", - ~initial_model=Model.load(Model.blank), + ~initial_model=Page.Store.load(), ) }; diff --git a/src/haz3lweb/Model.re b/src/haz3lweb/Model.re deleted file mode 100644 index 839c07a0c8..0000000000 --- a/src/haz3lweb/Model.re +++ /dev/null @@ -1,128 +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, -}; - -type t = { - editors: Editors.t, - settings: Settings.t, - results: ModelResults.t, - explainThisModel: ExplainThisModel.t, - ui_state, -}; - -let cutoff = (===); - -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 deleted file mode 100644 index 1481b54621..0000000000 --- a/src/haz3lweb/Settings.re +++ /dev/null @@ -1,35 +0,0 @@ -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) - }; - -[@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 fix_instructor_mode = settings => - if (settings.instructor_mode && !ExerciseSettings.show_instructor) { - {...settings, instructor_mode: false}; - } else { - settings; - }; 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 deleted file mode 100644 index f30a18ab85..0000000000 --- a/src/haz3lweb/Store.re +++ /dev/null @@ -1,432 +0,0 @@ -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 - ) { - | _ => - print_endline("Could not deserialize settings."); - 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 init = () => { - JsUtil.set_localstore( - save_ExplainThisModel_key, - serialize(ExplainThisModel.init), - ); - ExplainThisModel.init; - }; - - let load = (): ExplainThisModel.t => - switch (JsUtil.get_localstore(save_ExplainThisModel_key)) { - | None => init() - | Some(data) => deserialize(data) - }; - - let rec export = () => - switch (JsUtil.get_localstore(save_ExplainThisModel_key)) { - | None => - let _ = init(); - export(); - | Some(data) => data - }; - - 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, - ) - }; - }); - }; -}; diff --git a/src/haz3lweb/Update.re b/src/haz3lweb/Update.re deleted file mode 100644 index de814c4561..0000000000 --- a/src/haz3lweb/Update.re +++ /dev/null @@ -1,543 +0,0 @@ -open Util; -open Haz3lcore; - -include UpdateAction; // to prevent circularity - -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 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, _state: State.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) { - | 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 => 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 b67861090f..0000000000 --- a/src/haz3lweb/UpdateAction.re +++ /dev/null @@ -1,265 +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 */ - | 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(_) => 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 => 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 => 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..4d3f9d602f --- /dev/null +++ b/src/haz3lweb/app/Cursor.re @@ -0,0 +1,33 @@ +type cursor('update) = { + info: option(Haz3lcore.Info.t), + selected_text: option(string), + editor: option(Haz3lcore.Editor.t), + 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_action: _ => None, + undo_action: None, + redo_action: None, +}; + +let (let+) = (cursor, f) => map(f, cursor); diff --git a/src/haz3lweb/app/Export.re b/src/haz3lweb/app/Export.re new file mode 100644 index 0000000000..4d367350ea --- /dev/null +++ b/src/haz3lweb/app/Export.re @@ -0,0 +1,77 @@ +open Util; + +[@deriving (show({with_path: false}), sexp, yojson)] +type all = { + settings: string, + explainThisModel: string, + scratch: string, + exercise: string, + documentation: string, + log: string, +}; + +// fallback for saved state prior to release of lang doc in 490F22 +[@deriving (show({with_path: false}), sexp, yojson)] +type all_f22 = { + settings: string, + scratch: string, + exercise: string, + log: string, +}; + +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 = + ExercisesMode.Store.export(~settings=core_settings, ~instructor_mode); + {settings, explainThisModel, scratch, documentation, exercise, log}; +}; + +let export_all = (~settings, ~instructor_mode, ~log) => { + mk_all(~core_settings=settings, ~instructor_mode, ~log) |> yojson_of_all; +}; + +let import_all = (~import_log: string => unit, data, ~specs) => { + let all = + try(data |> Yojson.Safe.from_string |> all_of_yojson) { + | _ => + let all_f22 = data |> Yojson.Safe.from_string |> all_f22_of_yojson; + { + settings: all_f22.settings, + scratch: all_f22.scratch, + documentation: "", + exercise: all_f22.exercise, + log: all_f22.log, + explainThisModel: "", + }; + }; + Settings.Store.import(all.settings); + let settings = Settings.Store.load(); + ExplainThisModel.Store.import(all.explainThisModel); + let instructor_mode = settings.instructor_mode; + ScratchMode.Store.import(all.scratch); + ExercisesMode.Store.import( + ~settings=settings.core, + all.exercise, + ~specs, + ~instructor_mode, + ); + 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/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 4d98345dab..c2b596cc14 100644 --- a/src/haz3lweb/Log.re +++ b/src/haz3lweb/app/Log.re @@ -2,32 +2,6 @@ open Util; -let is_action_logged: UpdateAction.t => bool = - fun - | SetMeta(_) - | Save - | InitImportAll(_) - | InitImportScratchpad(_) - | Export(_) - | FinishImportAll(_) - | FinishImportScratchpad(_) - | Benchmark(_) - | DebugConsole(_) => false - | Reset - | TAB - | Set(_) - | SwitchScratchSlide(_) - | SwitchDocumentationSlide(_) - | SwitchEditor(_) - | ResetCurrentEditor - | PerformAction(_) - | Undo - | Redo - | UpdateResult(_) - | ToggleStepper(_) - | StepperAction(_, StepForward(_) | StepBackward) - | UpdateExplainThisModel(_) => true; - module DB = { open Ezjs_idb; @@ -72,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); @@ -101,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/app/Page.re b/src/haz3lweb/app/Page.re new file mode 100644 index 0000000000..673e32726b --- /dev/null +++ b/src/haz3lweb/app/Page.re @@ -0,0 +1,509 @@ +open Js_of_ocaml; +open Virtual_dom.Vdom; +open Node; +open Util; + +/* The top-level UI component of Hazel */ + +[@deriving (show({with_path: false}), sexp, yojson)] +type selection = Editors.Selection.t; + +module Model = { + type t = { + globals: Globals.Model.t, + editors: Editors.Model.t, + explain_this: ExplainThisModel.t, + selection, + }; + + let cutoff = (===); +}; + +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); + }; +}; + +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, + ); + 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, + ); + 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, + ); + 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 = + Editors.Selection.get_cursor_info( + ~selection=model.selection, + model.editors, + ); + 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 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 => + 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}; + }; +}; + +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 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)]) + } + ); + [ + Attr.on_keypress(_ => Effect.Prevent_default), + 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); + }), + ] + @ [ + 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, + CtxInspector.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("font-specimen"), + DecUtil.filters, + JsUtil.clipboard_shim, + ] + @ main_view(~get_log_and, ~cursor, ~inject, model), + ); + }; +}; diff --git a/src/haz3lweb/app/Store.re b/src/haz3lweb/app/Store.re new file mode 100644 index 0000000000..0665dcbce7 --- /dev/null +++ b/src/haz3lweb/app/Store.re @@ -0,0 +1,71 @@ +open Util; +// A generic key-value store for saving/loading data to/from local storage + +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 " ++ key_to_string(key) ++ "."); + default; + }; + + let save = (data: t): unit => + JsUtil.set_localstore(key_to_string(key), serialize(data)); + + let init = () => { + JsUtil.set_localstore(key_to_string(key), serialize(default())); + default(); + }; + + let load = (): t => + switch (JsUtil.get_localstore(key_to_string(key))) { + | None => init() + | Some(data) => deserialize(data, default()) + }; + + let rec export = () => + switch (JsUtil.get_localstore(key_to_string(key))) { + | None => + let _ = init(); + export(); + | Some(data) => data + }; + + let import = data => { + let data = deserialize(data, default()); + save(data); + }; +}; 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/FontSpecimen.re b/src/haz3lweb/app/common/FontSpecimen.re similarity index 100% rename from src/haz3lweb/view/FontSpecimen.re rename to src/haz3lweb/app/common/FontSpecimen.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..495ea6bee4 --- /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( + SlideSelect.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..f1fe88bc4b --- /dev/null +++ b/src/haz3lweb/app/editors/cell/CellEditor.re @@ -0,0 +1,176 @@ +open Haz3lcore; +open Virtual_dom.Vdom; +open Node; + +/* A "Cell" with user-editable text at the top, and evaluation results at the bottom. */ + +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, 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, + ~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, + ~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..f042b61e78 --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeEditable.re @@ -0,0 +1,276 @@ +open Js_of_ocaml; +open Haz3lcore; +open Virtual_dom.Vdom; +type editor_id = string; +open Util; + +module Model = CodeWithStatics.Model; + +/* A selectable editable code container component with statics and type-directed code completion. */ + +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)), + 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 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..36c30af2d4 --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeSelectable.re @@ -0,0 +1,80 @@ +open Haz3lcore; +open Util; + +/* A CodeEditor that's been restricted to only performing selection with + mouse/keyboard, no edits to the actual code. */ + +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) + |> 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..1951ce1742 --- /dev/null +++ b/src/haz3lweb/app/editors/code/CodeWithStatics.re @@ -0,0 +1,101 @@ +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. */ + +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_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 72% rename from src/haz3lweb/view/Deco.re rename to src/haz3lweb/app/editors/decoration/Deco.re index a616fe9eb0..56b019b6f0 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,86 @@ 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)); + }; + }; + 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)], + ) + |> Option.map(_, 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=["next-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/ExerciseMode.re b/src/haz3lweb/app/editors/mode/ExerciseMode.re new file mode 100644 index 0000000000..0db58233ff --- /dev/null +++ b/src/haz3lweb/app/editors/mode/ExerciseMode.re @@ -0,0 +1,547 @@ +open Haz3lcore; +open Virtual_dom.Vdom; +open Node; + +/* The exercises mode interface for a single exercise. Composed of multiple editors and results. */ + +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 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}; + }; + + [@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); + { + ...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, + ), + }; + | 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, + ); + (); + }, + ); + /* 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, + ), + your_tests: { + tests: + calculate( + cells.user_tests.editor.statics, + model.editors.your_tests.tests, + ), + 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 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", + ), + ); + + // 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) => + CtxInspector.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( + 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 wrong_impl_views = + List.mapi( + (i, cell) => { + InstructorOnly( + () => + editor_view( + HiddenBugs(i), + cell, + ~caption="Wrong Implementation " ++ string_of_int(i + 1), + ), + ) + }, + 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, + 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/app/editors/mode/ExercisesMode.re b/src/haz3lweb/app/editors/mode/ExercisesMode.re new file mode 100644 index 0000000000..4302c48390 --- /dev/null +++ b/src/haz3lweb/app/editors/mode/ExercisesMode.re @@ -0,0 +1,490 @@ +open Util; + +/* This file handles the pagenation of Exercise Mode, and switching between + exercises. ExerciseMode.re handles the actual exercise. */ + +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, + ) + @ SlideSelect.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= + SlideSelect.indicator_n( + model.current, + List.length(model.exercises), + ), + ); +}; diff --git a/src/haz3lweb/app/editors/mode/ScratchMode.re b/src/haz3lweb/app/editors/mode/ScratchMode.re new file mode 100644 index 0000000000..9dd61818ba --- /dev/null +++ b/src/haz3lweb/app/editors/mode/ScratchMode.re @@ -0,0 +1,375 @@ +open Haz3lcore; +open Util; + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = { + current: int, + scratchpads: list((string, CellEditor.Model.t)), + }; + + 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 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 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), + }; + | 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, + ) => { + SlideSelect.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 + ? SlideSelect.indicator_select( + ~signal=i => inject(SwitchSlide(i)), + model.current, + List.map(((s, _)) => s, model.scratchpads), + ) + : SlideSelect.indicator_n( + model.current, + List.length(model.scratchpads), + ), + ); + }; +}; 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/mode/SlideSelect.re b/src/haz3lweb/app/editors/mode/SlideSelect.re new file mode 100644 index 0000000000..8aa205d176 --- /dev/null +++ b/src/haz3lweb/app/editors/mode/SlideSelect.re @@ -0,0 +1,39 @@ +open Virtual_dom.Vdom; +open Node; +open Widgets; +open Util; + +let option_view = (name, n) => + option( + ~attrs=n == name ? [Attr.create("selected", "selected")] : [], + [text(n)], + ); + +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, + ) + ), + ], + List.mapi( + (i, name) => option_view(i == cur_slide ? name : name ++ "+", name), + names, + ), + ), +]; diff --git a/src/haz3lweb/app/editors/result/EvalResult.re b/src/haz3lweb/app/editors/result/EvalResult.re new file mode 100644 index 0000000000..4516c80369 --- /dev/null +++ b/src/haz3lweb/app/editors/result/EvalResult.re @@ -0,0 +1,562 @@ +open Util; + +module type Model = { + type t; +}; + +/* 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. */ + +module Model = { + [@deriving (show({with_path: false}), sexp, yojson)] + type evaluated_result = { + // Updated + exp: Haz3lcore.Exp.t, + state: Haz3lcore.EvaluatorState.t, + // Calculated + editor: CodeSelectable.Model.t, + }; + + [@deriving (show({with_path: false}), sexp, yojson)] + type result = + | NoElab + | Evaluation({ + elab: Haz3lcore.Exp.t, + result_updated: bool, + result: Haz3lcore.ProgramResult.t(evaluated_result), + }) + | Stepper(Stepper.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: ResultOk({state, _}), _}) => + Some( + state + |> Haz3lcore.EvaluatorState.get_tests + |> Haz3lcore.TestResults.mk_results, + ) + | Stepper(s) => + Some( + s.history + |> Stepper.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: ResultOk({state, _}), _}) => + Some( + state + |> Haz3lcore.EvaluatorState.get_tests + |> Haz3lcore.TestResults.mk_results, + ) + | Stepper(s) => + Some( + s.history + |> Stepper.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) => Stepper.Model.get_elaboration(s) + | _ => None + }; +}; + +module Update = { + open Updated; + + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | ToggleStepper + | StepperAction(Stepper.Update.t) + | EvalEditorAction(CodeSelectable.Update.t) + | UpdateResult(Haz3lcore.ProgramResult.t(Haz3lcore.ProgramResult.inner)); + + 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 = Stepper.Update.update(~settings, a, s); + {...model, result: Stepper(stepper)}; + | (StepperAction(_), _) => model |> Updated.return_quiet + | ( + EvalEditorAction(a), + { + result: + Evaluation({ + elab, + result: ResultOk({editor, state, exp}), + result_updated: false, + }), + _, + }, + ) => + let* ed' = CodeSelectable.Update.update(~settings, a, editor); + { + ...model, + result: + Evaluation({ + elab, + result: ResultOk({editor: ed', state, exp}), + result_updated: false, + }), + }; + | (EvalEditorAction(_), _) => model |> Updated.return_quiet + | (UpdateResult(update), {result: Evaluation({elab, _}), _}) => + { + ...model, + result: + Evaluation({ + elab, + result: + Haz3lcore.ProgramResult.map( + ({result: r, state: s}: Haz3lcore.ProgramResult.inner) => { + let exp = Haz3lcore.ProgramResult.Result.unbox(r); + let editor = + CodeSelectable.Model.mk_from_exp( + ~settings=settings.core, + exp, + ); + Model.{exp, state: s, editor}; + }, + update, + ), + result_updated: true, + }), + } + |> (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, result_updated})) + when Haz3lcore.Exp.fast_equal(elab, elab') => { + ...model, + result: Evaluation({elab, result, result_updated}), + } + // 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); + let editor = + CodeSelectable.Model.mk_from_exp(~settings, exp); + Haz3lcore.ProgramResult.ResultOk({exp, editor, state}); + | Error(e) => Haz3lcore.ProgramResult.ResultFail(e) + }; + }, + result_updated: false, + }), + } + + | Some(queue_worker) => + queue_worker(elab); + { + ...model, + result: + Evaluation({ + elab, + result: Haz3lcore.ProgramResult.ResultPending, + result_updated: false, + }), + }; + } + | (Evaluation, _) => {...model, result: NoElab} + | (Stepper, Stepper(s)) => + let s' = Stepper.Update.calculate(~settings, elab, s); + {...model, result: Stepper(s')}; + | (Stepper, _) => + let s = + Stepper.Model.init() |> Stepper.Update.calculate(~settings, elab); + {...model, result: Stepper(s)}; + }; + // Calculate evaluation editor + switch (model.result) { + | Evaluation({ + elab, + result: ResultOk({state, exp, _}), + result_updated: true, + }) => + let editor = CodeSelectable.Model.mk_from_exp(~settings, exp); + let editor = + CodeSelectable.Update.calculate( + ~settings, + ~stitch=x => x, + ~is_edited, + editor, + ); + { + ...model, + result: + Evaluation({ + elab, + result: ResultOk({editor, state, exp}), + result_updated: false, + }), + }; + | _ => model + }; + }; +}; + +module Selection = { + open Cursor; + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | Evaluation(CodeSelectable.Selection.t) + | Stepper(Stepper.Selection.t); + // TODO: Selection in stepper + + let get_cursor_info = (~selection: t, mr: Model.t): cursor(Update.t) => + switch (selection, mr.result) { + | (_, NoElab) => empty + | ( + Evaluation(selection), + Evaluation({result: ResultOk({editor, _}), _}), + ) => + let+ ci = CodeSelectable.Selection.get_cursor_info(~selection, editor); + Update.EvalEditorAction(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({result: ResultOk({editor, _}), _}), + ) => + CodeSelectable.Selection.handle_key_event(~selection, editor, event) + |> Option.map(x => Update.EvalEditorAction(x)) + | (Stepper(selection), Stepper(s)) => + Stepper.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(Model.evaluated_result), + ) => { + let editor = + switch (result) { + | ResultOk({editor, _}) => editor + | _ => + 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, _}) => [ + live_eval( + ~globals, + ~signal, + ~inject, + ~selected=selected == Some(Evaluation()), + ~locked, + elab, + result, + ), + ] + | Stepper(s) => + Stepper.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/Stepper.re b/src/haz3lweb/app/editors/result/Stepper.re new file mode 100644 index 0000000000..f57806d226 --- /dev/null +++ b/src/haz3lweb/app/editors/result/Stepper.re @@ -0,0 +1,511 @@ +open Util; +open Haz3lcore; +open Sexplib.Std; +open OptUtil.Syntax; + +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), + }; + + let init = () => { + history: Aba.singleton(Calc.Pending), + cached_settings: Calc.Pending, + }; + + let get_next_steps = (model: Aba.t(a, b)): list(b) => + model + |> Aba.hd + |> ( + fun + | Calculated({next_steps, _}) => { + next_steps; + } + | Pending => [] + ); + + 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); +}; + +module Update = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | 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 = + ( + ~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 = 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); + 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, + 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}: Model.t) => { + let settings = cached_settings |> Calc.set(settings); + let elab = + history + |> Aba.last_a + |> Calc.map_saved((u: Model.a') => u.expr) + |> Calc.set(~eq=Exp.fast_equal, elab); + print_endline("====="); + print_endline("Settings " ++ string_of_bool(settings |> Calc.is_new)); + + let (prev_a, history) = + Aba.fold_right( + (a: Model.a, b: Model.b, (prev_a: Calc.t(Model.a'), history)) => { + print_endline("X " ++ string_of_bool(prev_a |> Calc.is_new)); + let next_a = get_next_a(~settings, prev_a, b, a) |> Calc.to_option; + switch (next_a) { + | None => (prev_a, history) + | Some(next_a) => + print_endline( + "naed " + ++ string_of_bool( + (next_a |> Calc.get_value).editor |> Calc.is_new, + ), + ); + (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; + print_endline("New!"); + 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, + }; + }; +}; + +module Selection = { + [@deriving (show({with_path: false}), sexp, yojson)] + type t = + | A(int, StepperEditor.Selection.t); + + let handle_key_event = + (~selection: t, ~event, mr: Model.t): option(Update.t) => { + let A(i, s) = selection; + let a: Model.a = mr.history |> Aba.get_as |> List.nth(_, i); + switch (a) { + | Calculated(a) => + let+ x = + StepperEditor.Selection.handle_key_event( + ~selection=s, + a.editor |> Calc.get_value, + event, + ); + Update.StepperEditor(i, x); + | Pending => 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(StepBackward), + ~disabled=!Model.can_undo(stepper), + ~tooltip="Step Backwards", + ); + let button_hide_stepper = + Widgets.toggle(~tooltip="Show Stepper", "s", true, _ => + signal(HideStepper) + ); + let toggle_show_history = + Widgets.toggle( + ~tooltip="Show History", + "h", + settings.core.evaluation.stepper_history, + _ => + inject_global(Set(Evaluation(ShowRecord))) + ); + let eval_settings = + Widgets.button(Icons.gear, _ => + inject_global(Set(Evaluation(ShowSettings))) + ); + let previous_steps = { + stepper.history + |> Aba.aba_triples + |> (settings.core.evaluation.stepper_history ? x => x : (_ => [])) + |> ( + settings.core.evaluation.show_hidden_steps + ? x => x : List.filter(((_, b: Model.b, _)) => !b.hidden) + ) + |> List.mapi((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(i + 1, ())), + ~inject= + (x: StepperEditor.Update.t) => + inject(StepperEditor(i + 1, x)), + ~signal= + fun + | TakeStep(_) => Ui_effect.Ignore + | MakeActive => signal(MakeActive(A(i + 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"])], + ( + switch (model) { + | Calculated(model) => [ + div(~attrs=[Attr.class_("equiv")], [Node.text("≡")]), + StepperEditor.View.view( + ~globals, + ~selected=selection == Some(A(current_n, ())), + ~inject= + (x: StepperEditor.Update.t) => + inject(StepperEditor(current_n, x)), + ~signal= + fun + | TakeStep(x) => inject(Update.StepForward(x)) + | MakeActive => signal(MakeActive(A(current_n, ()))), + ~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, + ] + ), + ); + }; + 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/app/editors/result/StepperEditor.re b/src/haz3lweb/app/editors/result/StepperEditor.re new file mode 100644 index 0000000000..ee07bee439 --- /dev/null +++ b/src/haz3lweb/app/editors/result/StepperEditor.re @@ -0,0 +1,86 @@ +open Util; +open Haz3lcore; + +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 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/app/editors/result/TestView.re b/src/haz3lweb/app/editors/result/TestView.re new file mode 100644 index 0000000000..ecfddcea56 --- /dev/null +++ b/src/haz3lweb/app/editors/result/TestView.re @@ -0,0 +1,66 @@ +open Virtual_dom.Vdom; +open Node; +open Util.Web; + +module TestStatus = Haz3lcore.TestStatus; +module TestMap = Haz3lcore.TestMap; +module TestResults = Haz3lcore.TestResults; + +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(_ => inject_jump(id))], + [], + ); +}; + +let test_bar = (~inject_jump, ~test_results: TestResults.t) => + div( + ~attrs=[Attr.class_("test-bar")], + 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 + +let percent_view = (n: int, p: int): Node.t => { + let percentage = + n == 0 ? 100. : 100. *. float_of_int(p) /. float_of_int(n); + div( + ~attrs=[clss(["test-percent", n == p ? "all-pass" : "some-fail"])], + [text(Printf.sprintf("%.0f%%", percentage))], + ); +}; + +let test_percentage = (test_results: TestResults.t): Node.t => + percent_view(test_results.total, test_results.passing); + +let test_text = (test_results: TestResults.t): Node.t => + div( + ~attrs=[Attr.class_("test-text")], + [ + test_percentage(test_results), + div([text(":")]), + text(TestResults.test_summary_str(test_results)), + ], + ); + +let test_summary = (~inject_jump, ~test_results: option(TestResults.t)) => { + div( + ~attrs=[clss(["test-summary"])], + { + switch (test_results) { + | None => [Node.text("No test results available.")] + | Some(test_results) => [ + test_text(test_results), + test_bar(~inject_jump, ~test_results), + ] + }; + }, + ); +}; + +let view_of_main_title_bar = (title_text: string) => + div( + ~attrs=[clss(["title-bar", "panel-title-bar"])], + [Node.text(title_text)], + ); 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 cbfdf4df9f..b155eece52 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/app/explainthis/ExplainThisUpdate.re b/src/haz3lweb/app/explainthis/ExplainThisUpdate.re new file mode 100644 index 0000000000..d0bd4fedff --- /dev/null +++ b/src/haz3lweb/app/explainthis/ExplainThisUpdate.re @@ -0,0 +1,90 @@ +open ExplainThisForm; +open ExplainThisModel; +open Util; + +[@deriving (show({with_path: false}), sexp, yojson)] +type update = + | SpecificityOpen(bool) + | ToggleExplanationFeedback(group_id, form_id, feedback_option) + | ToggleExampleFeedback(group_id, form_id, example_id, feedback_option) + | UpdateGroupSelection(group_id, form_id); + +let set_update = + (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 + @ [{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}], + } + }; + {...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/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..13d19d8419 --- /dev/null +++ b/src/haz3lweb/app/globals/Globals.re @@ -0,0 +1,92 @@ +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 = { + 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/app/globals/Settings.re b/src/haz3lweb/app/globals/Settings.re new file mode 100644 index 0000000000..d9d369dfe3 --- /dev/null +++ b/src/haz3lweb/app/globals/Settings.re @@ -0,0 +1,224 @@ +open Util; + +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, + }; + + 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; +}; + +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/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/Keyboard.re b/src/haz3lweb/app/input/Keyboard.re new file mode 100644 index 0000000000..2d39ac24a0 --- /dev/null +++ b/src/haz3lweb/app/input/Keyboard.re @@ -0,0 +1,116 @@ +open Haz3lcore; +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)); + +let meta = (sys: Key.sys): string => { + switch (sys) { + | Mac => "cmd" + | PC => "ctrl" + }; +}; + +let handle_key_event = (k: Key.t): option(Action.t) => { + let now = (a: Action.t) => Some(a); + switch (k) { + | {key: U(key), _} => + /* Keu-UPpEvents: + NOTE: Remember that since there is a keyup for every + keydown, making an update here may trigger an entire + extra redraw, contingent on model.cutoff */ + switch (key) { + | _ => None + } + | {key: D(key), sys: _, shift, meta: Up, ctrl: Up, alt: Up} => + switch (shift, key) { + | (Up, "ArrowLeft") => now(Move(Local(Left(ByChar)))) + | (Up, "ArrowRight") => now(Move(Local(Right(ByChar)))) + | (Up, "ArrowUp") => now(Move(Local(Up))) + | (Up, "ArrowDown") => now(Move(Local(Down))) + | (Up, "Home") => now(Move(Extreme(Left(ByToken)))) + | (Up, "End") => now(Move(Extreme(Right(ByToken)))) + | (Up, "Backspace") => now(Destruct(Left)) + | (Up, "Delete") => now(Destruct(Right)) + | (Up, "Escape") => now(Unselect(None)) + | (Up, "F12") => now(Jump(BindingSiteOfIndicatedVar)) + | (Down, "Tab") => now(Move(Goal(Piece(Grout, Left)))) + | (Down, "ArrowLeft") => now(Select(Resize(Local(Left(ByToken))))) + | (Down, "ArrowRight") => now(Select(Resize(Local(Right(ByToken))))) + | (Down, "ArrowUp") => now(Select(Resize(Local(Up)))) + | (Down, "ArrowDown") => now(Select(Resize(Local(Down)))) + | (Down, "Home") => now(Select(Resize(Extreme(Left(ByToken))))) + | (Down, "End") => now(Select(Resize(Extreme(Right(ByToken))))) + | (_, "Enter") => now(Insert(Form.linebreak)) + | _ when String.length(key) == 1 => + /* Note: length==1 prevent specials like + * SHIFT from being captured here */ + now(Insert(key)) + | _ => None + } + | {key: D(key), sys: Mac, shift: Down, meta: Down, ctrl: Up, alt: Up} => + switch (key) { + | "ArrowLeft" => now(Select(Resize(Extreme(Left(ByToken))))) + | "ArrowRight" => now(Select(Resize(Extreme(Right(ByToken))))) + | "ArrowUp" => now(Select(Resize(Extreme(Up)))) + | "ArrowDown" => now(Select(Resize(Extreme(Down)))) + | _ => None + } + | {key: D(key), sys: PC, shift: Down, meta: Up, ctrl: Down, alt: Up} => + switch (key) { + | "ArrowLeft" => now(Select(Resize(Local(Left(ByToken))))) + | "ArrowRight" => now(Select(Resize(Local(Right(ByToken))))) + | "ArrowUp" => now(Select(Resize(Local(Up)))) + | "ArrowDown" => now(Select(Resize(Local(Down)))) + | "Home" => now(Select(Resize(Extreme(Up)))) + | "End" => now(Select(Resize(Extreme(Down)))) + | _ => None + } + | {key: D(key), sys: Mac, shift: Up, meta: Down, ctrl: Up, alt: Up} => + switch (key) { + | "d" => now(Select(Term(Current))) + | "p" => now(Pick_up) + | "a" => now(Select(All)) + | "k" => Some(Reparse) + | "/" => Some(Buffer(Set(TyDi))) + | "ArrowLeft" => now(Move(Extreme(Left(ByToken)))) + | "ArrowRight" => now(Move(Extreme(Right(ByToken)))) + | "ArrowUp" => now(Move(Extreme(Up))) + | "ArrowDown" => now(Move(Extreme(Down))) + | _ => None + } + | {key: D(key), sys: PC, shift: Up, meta: Up, ctrl: Down, alt: Up} => + switch (key) { + | "d" => now(Select(Term(Current))) + | "p" => now(Pick_up) + | "a" => now(Select(All)) + | "k" => Some(Reparse) + | "/" => Some(Buffer(Set(TyDi))) + | "ArrowLeft" => now(Move(Local(Left(ByToken)))) + | "ArrowRight" => now(Move(Local(Right(ByToken)))) + | "Home" => now(Move(Extreme(Up))) + | "End" => now(Move(Extreme(Down))) + | _ => None + } + | {key: D(key), sys: Mac, shift: Up, meta: Up, ctrl: Down, alt: Up} => + switch (key) { + | "a" => now(Move(Extreme(Left(ByToken)))) + | "e" => now(Move(Extreme(Right(ByToken)))) + | _ => None + } + | {key: D("f"), sys: PC, shift: Up, meta: Up, ctrl: Up, alt: Down} => + 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(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))) + | "ArrowUp" => now(MoveToBackpackTarget(Up)) + | "ArrowDown" => now(MoveToBackpackTarget(Down)) + | _ => None + } + | _ => None + }; +}; 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/app/inspector/CtxInspector.re b/src/haz3lweb/app/inspector/CtxInspector.re new file mode 100644 index 0000000000..3e48eb2109 --- /dev/null +++ b/src/haz3lweb/app/inspector/CtxInspector.re @@ -0,0 +1,80 @@ +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 => + Globals.Update.JumpToTile(Haz3lcore.Ctx.get_id(entry)); + +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(_ => globals.inject_global(jump_to(entry))), + clss(["context-entry", "code"]), + ], + [ + div_name([text(name)]), + div(~attrs=[clss(["seperator"])], [text(":")]), + view_type(typ, ~info_map=Haz3lcore.Id.Map.empty), + ], + ) + | TVarEntry({name, kind, _}) => + div( + ~attrs=[ + Attr.on_click(_ => globals.inject_global(jump_to(entry))), + clss(["context-entry", "code"]), + ], + [ + div_name([alias_view(name)]), + div(~attrs=[clss(["seperator"])], [text("::")]), + Kind.view(~globals, kind), + ], + ) + }; +}; + +let ctx_view = (~globals, ctx: Haz3lcore.Ctx.t): Node.t => + div( + ~attrs=[clss(["context-inspector"])], + List.map( + context_entry_view(~globals), + ctx |> Haz3lcore.Ctx.filter_duplicates |> List.rev, + ), + ); + +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(~globals)); + +let view = + (~globals: Globals.t, ci: option(Haz3lcore.Statics.Info.t)): Node.t => { + let clss = + clss( + ["context-inspector"] + @ (globals.settings.context_inspector ? ["visible"] : []), + ); + switch (ci) { + | Some(ci) when globals.settings.context_inspector => + div(~attrs=[clss], ctx_sorts_view(~globals, ci)) + | _ => div([]) + }; +}; 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..e27ee32e7c 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([CtxInspector.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/Kind.re b/src/haz3lweb/app/inspector/Kind.re new file mode 100644 index 0000000000..0eee9db324 --- /dev/null +++ b/src/haz3lweb/app/inspector/Kind.re @@ -0,0 +1,26 @@ +open Virtual_dom.Vdom; +open Node; +open Util.Web; + +let view = (~globals, kind: Haz3lcore.Ctx.kind): Node.t => + switch (kind) { + | 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/app/inspector/ProjectorPanel.re b/src/haz3lweb/app/inspector/ProjectorPanel.re new file mode 100644 index 0000000000..3fc7fbd0a0 --- /dev/null +++ b/src/haz3lweb/app/inspector/ProjectorPanel.re @@ -0,0 +1,135 @@ +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: option(Editor.t) => bool = + fun + | 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.editor) && applicable_projectors != []; + let select_view = + Node.select( + ~attrs=[ + Attr.on_change((_, name) => + inject(Action.SetIndicated(ProjectorView.of_name(name))) + ), + ], + (might_project(cursor.editor) ? 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.editor), + ); + div( + ~attrs=[Attr.id("projectors")], + (should_show ? [select_view] : []) @ [toggle_view], + ); +}; diff --git a/src/haz3lweb/app/menubar/NutMenu.re b/src/haz3lweb/app/menubar/NutMenu.re new file mode 100644 index 0000000000..2155d0f26f --- /dev/null +++ b/src/haz3lweb/app/menubar/NutMenu.re @@ -0,0 +1,116 @@ +open Virtual_dom.Vdom; +open Node; +open Util.Web; +open Widgets; +open Haz3lcore; + +// 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, _ => + globals.inject_global(Set(setting)) + ); + div_c( + "group", + [ + div_c("name", [text(name)]), + div_c("contents", List.map(toggle, ts)), + ], + ); +}; + +let semantics_group = (~globals) => { + settings_group( + ~globals, + "Semantics", + [ + ("τ", "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", + // settings.explainThis.show_feedback, + // ExplainThis(ToggleShowFeedback), + // ), + ], + ); +}; + +let values_group = (~globals: Globals.t) => { + let s = globals.settings.core.evaluation; + settings_group( + ~globals, + "Value Display", + [ + ("λ", "Functions", s.show_fn_bodies, Evaluation(ShowFnBodies)), + ("|", "Cases", s.show_case_clauses, Evaluation(ShowCaseClauses)), + ("f", "Fixpoints", s.show_fixpoints, Evaluation(ShowFixpoints)), + (Unicode.castArrowSym, "Casts", s.show_casts, Evaluation(ShowCasts)), + ], + ); +}; + +let stepper_group = (~globals: Globals.t) => { + let s = globals.settings.core.evaluation; + settings_group( + ~globals, + "Stepper", + [ + ("🔍", "Show lookups", s.show_lookup_steps, Evaluation(ShowLookups)), + ( + "🤫", + "Show hidden", + s.show_hidden_steps, + Evaluation(ShowHiddenSteps), + ), + ("⏯️", "Filters", s.show_stepper_filters, Evaluation(ShowFilters)), + ], + ); +}; + +let dev_group = (~globals) => { + settings_group( + ~globals, + "Developer", + [ + ("✓", "Benchmarks", globals.settings.benchmark, Benchmark), + ("𝑒", "Elaboration", globals.settings.core.elaborate, Elaborate), + ("↵", "Whitespace", globals.settings.secondary_icons, SecondaryIcons), + ], + ); +}; + +let settings_menu = (~globals) => { + [ + semantics_group(~globals), + values_group(~globals), + stepper_group(~globals), + dev_group(~globals), + ]; +}; 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 95% rename from src/haz3lweb/view/DebugMode.re rename to src/haz3lweb/debug/DebugMode.re index 543e7cc757..58208f0b82 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 8d25155dc5..a87a4ce70e 100644 --- a/src/haz3lweb/dune +++ b/src/haz3lweb/dune @@ -9,12 +9,12 @@ (name workerServer) (modules WorkerServer) (libraries + str incr_dom virtual_dom.input_widgets util ppx_yojson_conv.expander haz3lcore - haz3lschool pretty omd) (js_of_ocaml) @@ -29,7 +29,7 @@ (library (name haz3lweb) (modules - (:standard \ Main) + (:standard \ Main Gradescope) \ Worker WorkerServer) @@ -43,7 +43,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..fbcc55ee45 --- /dev/null +++ b/src/haz3lweb/exercises/Exercise.re @@ -0,0 +1,661 @@ +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 => + Exp.{ + term: + Exp.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 deleted file mode 100644 index 8946a4818c..0000000000 --- a/src/haz3lweb/explainthis/ExplainThisUpdate.re +++ /dev/null @@ -1,86 +0,0 @@ -open Util; -open ExplainThisForm; -open ExplainThisModel; - -[@deriving (show({with_path: false}), sexp, yojson)] -type update = - | SpecificityOpen(bool) - | ToggleExplanationFeedback(group_id, form_id, feedback_option) - | ToggleExampleFeedback(group_id, form_id, example_id, feedback_option) - | 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) => - pre_example - @ [{...example, 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}], - } - }; - {...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, - }; - }; -}; 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 65c01e1a6f..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, - ) - : DHExp.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 deleted file mode 100644 index 672988d049..0000000000 --- a/src/haz3lweb/view/ContextInspector.re +++ /dev/null @@ -1,66 +0,0 @@ -open Virtual_dom.Vdom; -open Node; -open Util.Web; - -let jump_to = entry => - UpdateAction.PerformAction(Jump(TileId(Haz3lcore.Ctx.get_id(entry)))); - -let context_entry_view = (~inject, entry: Haz3lcore.Ctx.entry): Node.t => { - let div_name = div(~attrs=[clss(["name"])]); - switch (entry) { - | VarEntry({name, typ, _}) - | ConstructorEntry({name, typ, _}) => - div( - ~attrs=[ - Attr.on_click(_ => inject(jump_to(entry))), - clss(["context-entry", "code"]), - ], - [ - div_name([text(name)]), - div(~attrs=[clss(["seperator"])], [text(":")]), - Type.view(typ), - ], - ) - | TVarEntry({name, kind, _}) => - div( - ~attrs=[ - Attr.on_click(_ => inject(jump_to(entry))), - clss(["context-entry", "code"]), - ], - [ - div_name([Type.alias_view(name)]), - div(~attrs=[clss(["seperator"])], [text("::")]), - Kind.view(kind), - ], - ) - }; -}; - -let ctx_view = (~inject, ctx: Haz3lcore.Ctx.t): Node.t => - div( - ~attrs=[clss(["context-inspector"])], - List.map( - context_entry_view(~inject), - ctx |> Haz3lcore.Ctx.filter_duplicates |> List.rev, - ), - ); - -let ctx_sorts_view = (~inject, ci: Haz3lcore.Statics.Info.t) => - Haz3lcore.Info.ctx_of(ci) - |> Haz3lcore.Ctx.filter_duplicates - |> List.rev - |> List.map(context_entry_view(~inject)); - -let view = - (~inject, ~settings: Settings.t, ci: option(Haz3lcore.Statics.Info.t)) - : Node.t => { - let clss = - clss( - ["context-inspector"] @ (settings.context_inspector ? ["visible"] : []), - ); - switch (ci) { - | Some(ci) when settings.context_inspector => - div(~attrs=[clss], ctx_sorts_view(~inject, ci)) - | _ => div([]) - }; -}; diff --git a/src/haz3lweb/view/EditorModeView.re b/src/haz3lweb/view/EditorModeView.re deleted file mode 100644 index dea884266f..0000000000 --- a/src/haz3lweb/view/EditorModeView.re +++ /dev/null @@ -1,132 +0,0 @@ -open Virtual_dom.Vdom; -open Node; -open Widgets; - -let option_view = (name, n) => - option( - ~attrs=n == name ? [Attr.create("selected", "selected")] : [], - [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"], - ), - ), - ], - ); - -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), - ), - ]; -}; - -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 deleted file mode 100644 index 2b291c99f4..0000000000 --- a/src/haz3lweb/view/ExerciseMode.re +++ /dev/null @@ -1,318 +0,0 @@ -open Util; -open Haz3lcore; -open Virtual_dom.Vdom; -open Node; - -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 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, - ); - }; - 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 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( - { - 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)", - ), - exp_ctx_view, - ]), - ]); - }, - ); - 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, - ), - ], - ), - ); - 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, - ), - ) - }, - 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, - ), - ), - ); - }; - 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 hidden_tests_view = - InstructorOnly( - () => - editor_view( - HiddenTests, - ~caption="Hidden Tests", - ~editor=eds.hidden_tests.tests, - ~di=instructor, - ), - ); - - 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 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", - ); diff --git a/src/haz3lweb/view/Kind.re b/src/haz3lweb/view/Kind.re deleted file mode 100644 index 8feb3af0b0..0000000000 --- a/src/haz3lweb/view/Kind.re +++ /dev/null @@ -1,9 +0,0 @@ -open Virtual_dom.Vdom; -open Node; -open Util.Web; - -let view = (kind: Haz3lcore.Ctx.kind): Node.t => - switch (kind) { - | Singleton(ty) => div_c("kind-view", [Type.view(ty)]) - | Abstract => div_c("kind-view", [text("Type")]) - }; diff --git a/src/haz3lweb/view/NutMenu.re b/src/haz3lweb/view/NutMenu.re deleted file mode 100644 index b67f406504..0000000000 --- a/src/haz3lweb/view/NutMenu.re +++ /dev/null @@ -1,237 +0,0 @@ -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) => { - let toggle = ((_icon, tooltip, bool, setting)) => - toggle_named("", ~tooltip, bool, _ => inject(UpdateAction.Set(setting))); - div_c( - "group", - [ - div_c("name", [text(name)]), - div_c("contents", List.map(toggle, ts)), - ], - ); -}; - -let semantics_group = (~inject, ~settings: Settings.t) => { - settings_group( - ~inject, - "Semantics", - [ - ("τ", "Types", settings.core.statics, Statics), - ("⇲", "Completion", settings.core.assist, Assist), - ("𝛿", "Evaluation", settings.core.dynamics, Dynamics), - ("?", "Docs", settings.explainThis.show, ExplainThis(ToggleShow)), - // ( - // "👍", - // "Feedback", - // settings.explainThis.show_feedback, - // ExplainThis(ToggleShowFeedback), - // ), - ], - ); -}; - -let values_group = (~inject, ~settings: Settings.t) => { - let s = settings.core.evaluation; - settings_group( - ~inject, - "Value Display", - [ - ("λ", "Functions", s.show_fn_bodies, Evaluation(ShowFnBodies)), - ("|", "Cases", s.show_case_clauses, Evaluation(ShowCaseClauses)), - ("f", "Fixpoints", s.show_fixpoints, Evaluation(ShowFixpoints)), - (Unicode.castArrowSym, "Casts", s.show_casts, Evaluation(ShowCasts)), - ], - ); -}; - -let stepper_group = (~inject, ~settings: Settings.t) => { - let s = settings.core.evaluation; - settings_group( - ~inject, - "Stepper", - [ - ("🔍", "Show lookups", s.show_lookup_steps, Evaluation(ShowLookups)), - ( - "🤫", - "Show hidden", - s.show_hidden_steps, - Evaluation(ShowHiddenSteps), - ), - ("⏯️", "Filters", s.show_stepper_filters, Evaluation(ShowFilters)), - ], - ); -}; - -let dev_group = (~inject, ~settings: Settings.t) => { - settings_group( - ~inject, - "Developer", - [ - ("✓", "Benchmarks", settings.benchmark, Benchmark), - ("𝑒", "Elaboration", settings.core.elaborate, Elaborate), - ("↵", "Whitespace", settings.secondary_icons, SecondaryIcons), - ], - ); -}; - -let settings_menu = (~inject, ~settings: Settings.t) => { - [ - semantics_group(~inject, ~settings), - values_group(~inject, ~settings), - stepper_group(~inject, ~settings), - dev_group(~inject, ~settings), - ]; -}; - -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 deleted file mode 100644 index df98ba5ee9..0000000000 --- a/src/haz3lweb/view/Page.re +++ /dev/null @@ -1,198 +0,0 @@ -open Util; -open Web; -open Js_of_ocaml; -open Haz3lcore; -open Virtual_dom.Vdom; -open Node; - -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)]) - } - }; -}; - -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))); - }), - ]; -}; - -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, - ); - (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, - ); - 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, - ); - let statics = - Exercise.statics_of_stiched_dynamics(exercise, stitched_dynamics); - 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, - ); - (view, cursor_info); - }; - - 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 get_selection = (model: Model.t): string => - model.editors |> Editors.get_editor |> Printer.to_string_selection; - -let view = (~inject: UpdateAction.t => Ui_effect.t(unit), model: Model.t) => - div( - ~attrs=[ - Attr.id("page"), - ...handlers(~inject, Editors.get_editor(model.editors)), - ], - [ - FontSpecimen.view("font-specimen"), - DecUtil.filters, - JsUtil.clipboard_shim, - ] - @ main_view(~inject, model), - ); diff --git a/src/haz3lweb/view/ScratchMode.re b/src/haz3lweb/view/ScratchMode.re deleted file mode 100644 index 7fdc8eb361..0000000000 --- a/src/haz3lweb/view/ScratchMode.re +++ /dev/null @@ -1,81 +0,0 @@ -open Util; -open Haz3lcore; - -type state = (Id.t, Editor.t); - -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, - ), - ]; -}; - -let export_button = (inject: Update.t => Ui_effect.t(unit)) => - Widgets.button_named( - Icons.export, - _ => inject(Export(ExportScratchSlide)), - ~tooltip="Export Scratchpad", - ); -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 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; - }; - }, - ~tooltip="Reset Editor", - ); diff --git a/src/haz3lweb/view/StepperView.re b/src/haz3lweb/view/StepperView.re deleted file mode 100644 index b3d3884c4d..0000000000 --- a/src/haz3lweb/view/StepperView.re +++ /dev/null @@ -1,221 +0,0 @@ -open Virtual_dom.Vdom; -open Node; -open Haz3lcore; - -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), - ], - ); - [ - 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 stepper_view = - ( - ~inject, - ~settings: CoreSettings.Evaluation.t, - ~font_metrics, - ~result_key, - ~read_only: bool, - stepper: Stepper.t, - ) => { - let step_dh_code = - ( - ~next_steps, - {previous_step, hidden_steps, chosen_step, d}: Stepper.step_info, - ) => - div( - ~attrs=[Attr.classes(["result"])], - [ - DHCode.view( - ~inject, - ~settings, - ~selected_hole_instance=None, - ~font_metrics, - ~width=80, - ~previous_step, - ~chosen_step, - ~hidden_steps, - ~result_key, - ~next_steps, - ~infomap=Id.Map.empty, - d, - ), - ], - ); - let history = Stepper.get_history(~settings, stepper); - switch (history) { - | [] => [] - | [hd, ...tl] => - let button_back = - Widgets.button_d( - Icons.undo, - inject(UpdateAction.StepperAction(result_key, StepBackward)), - ~disabled=!Stepper.can_undo(~settings, stepper), - ~tooltip="Step Backwards", - ); - let button_hide_stepper = - Widgets.toggle(~tooltip="Show Stepper", "s", true, _ => - inject(UpdateAction.ToggleStepper(result_key)) - ); - let toggle_show_history = - Widgets.toggle(~tooltip="Show History", "h", settings.stepper_history, _ => - inject(Set(Evaluation(ShowRecord))) - ); - let eval_settings = - Widgets.button(Icons.gear, _ => - inject(Set(Evaluation(ShowSettings))) - ); - let current = - 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, - ), - ], - ), - ] - @ 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) : []); - }; -}; diff --git a/src/haz3lweb/view/TestView.re b/src/haz3lweb/view/TestView.re deleted file mode 100644 index 1b01158c56..0000000000 --- a/src/haz3lweb/view/TestView.re +++ /dev/null @@ -1,199 +0,0 @@ -open Virtual_dom.Vdom; -open Node; -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 status = reports |> TestMap.joint_status |> TestStatus.to_string; - div( - ~attrs=[ - clss(["segment", status]), - Attr.on_click(jump_to_test(~inject, pos, id)), - ], - [], - ); -}; - -let test_bar = (~inject, ~test_results: TestResults.t, pos) => - div( - ~attrs=[Attr.class_("test-bar")], - List.map(test_bar_segment(~inject, pos), test_results.test_map), - ); - -// result_summary_str and test_summary_str have been moved to haz3lcore/TestResults.re - -let percent_view = (n: int, p: int): Node.t => { - let percentage = - n == 0 ? 100. : 100. *. float_of_int(p) /. float_of_int(n); - div( - ~attrs=[clss(["test-percent", n == p ? "all-pass" : "some-fail"])], - [text(Printf.sprintf("%.0f%%", percentage))], - ); -}; - -let test_percentage = (test_results: TestResults.t): Node.t => - percent_view(test_results.total, test_results.passing); - -let test_text = (test_results: TestResults.t): Node.t => - div( - ~attrs=[Attr.class_("test-text")], - [ - test_percentage(test_results), - div([text(":")]), - text(TestResults.test_summary_str(test_results)), - ], - ); - -let test_summary = (~inject, ~test_results: option(TestResults.t)) => { - div( - ~attrs=[clss(["test-summary"])], - { - switch (test_results) { - | None => [Node.text("No test results available.")] - | Some(test_results) => [ - test_text(test_results), - test_bar(~inject, ~test_results, YourTestsTesting), - ] - }; - }, - ); -}; - -let view_of_main_title_bar = (title_text: string) => - div( - ~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 622dcf766e..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(Typ.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(Typ.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..c9f2ee2ca4 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,19 +39,30 @@ 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 { +.code-editor.selected{ background-color: var(--cell-active); } +.result .cell-item { + padding: 0em +} + +.result .code-editor.selected{ + background-color: var(--cell-result); +} + .title-cell { padding-left: 1em; } @@ -62,10 +73,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..84cc04f869 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,25 @@ content: "←"; } -.steppable, -.steppable *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { +.tile-next-step path, +.tile-next-step path *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { outline: 1px var(--step-hole-color); - background-color: var(--shard-selected); + fill: var(--G1); cursor: pointer; } -.stepped, -.stepped *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { +.tile-taken-step path, +.tile-taken-step path *:not(.DHCode .EmptyHole *, .DHCode .EmptyHole) { border: 1px var(--step-hole-color); - background-color: var(--Y1); + fill: var(--BR1); +} + +.child-line.Exp.next-step-line { + stroke: var(--G2); +} + +.taken-step-line { + stroke: var(--BR1); } .substituted { @@ -303,3 +303,20 @@ transform: scale(100%); cursor: not-allowed; } + +.tile-next-step .tile-path.Exp.indicated { + fill: #8aeda6; +} + +.tile-taken-step .tile-path.Exp.indicated { + fill: #ddcda3; +} + +svg.tile-next-step { + pointer-events: all; + cursor: pointer; +} + +.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/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 9c6bed90b0..350838a870 100644 --- a/src/util/ListUtil.re +++ b/src/util/ListUtil.re @@ -526,3 +526,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 c901907b60..60e65c5227 100644 --- a/src/util/Util.re +++ b/src/util/Util.re @@ -19,6 +19,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;