diff --git a/src/hazelcore/semantics/Action.re b/src/hazelcore/semantics/Action.re index c464b5c116..499db23ca5 100644 --- a/src/hazelcore/semantics/Action.re +++ b/src/hazelcore/semantics/Action.re @@ -45,6 +45,25 @@ type t = | Backspace | Construct(shape); +/* group entries in undo_history if their shapes are similar */ +let can_group_shape = (shape_1: shape, shape_2: shape): bool => { + switch (shape_1, shape_2) { + | (SLine, SLine) + | (SChar(_), _) => true + | (SParenthesized, _) + | (SList, _) + | (SAsc, _) + | (SLam, _) + | (SListNil, _) + | (SInj(_), _) + | (SLet, _) + | (SLine, _) + | (SCase, _) + | (SOp(_), _) + | (SApPalette(_), _) => false + }; +}; + module Outcome = { type t('success) = | Succeeded('success) diff --git a/src/hazelcore/semantics/CursorInfo.re b/src/hazelcore/semantics/CursorInfo.re index 17df4a1be9..dda0836601 100644 --- a/src/hazelcore/semantics/CursorInfo.re +++ b/src/hazelcore/semantics/CursorInfo.re @@ -80,6 +80,16 @@ type typed = | OnLine | OnRule; +type cursor_term = + | Exp(CursorPosition.t, UHExp.operand) + | Pat(CursorPosition.t, UHPat.operand) + | Typ(CursorPosition.t, UHTyp.operand) + | ExpOp(CursorPosition.t, UHExp.operator) + | PatOp(CursorPosition.t, UHPat.operator) + | TypOp(CursorPosition.t, UHTyp.operator) + | Line(CursorPosition.t, UHExp.line) + | Rule(CursorPosition.t, UHExp.rule); + // TODO refactor into variants // based on term family and shape [@deriving sexp] @@ -90,6 +100,154 @@ type t = { uses: option(UsageAnalysis.uses_list), }; +let rec extract_cursor_term = (exp: ZExp.t): (option(cursor_term), bool) => { + let cursor_term = extract_cursor_exp_term(exp); + let prev_is_empty_line = { + let prefix = ZList.prj_prefix(exp); + switch (ListUtil.split_last(prefix)) { + | None => false + | Some((_, elt)) => UHExp.is_empty_line(elt) + }; + }; + (cursor_term, prev_is_empty_line); +} +and extract_cursor_exp_term = (exp: ZExp.t): option(cursor_term) => { + extract_from_zline(ZList.prj_z(exp)); +} +and extract_from_zline = (zline: ZExp.zline): option(cursor_term) => { + switch (zline) { + | CursorL(cursor_pos, uex_line) => Some(Line(cursor_pos, uex_line)) + | ExpLineZ(zopseq) => extract_from_zexp_opseq(zopseq) + | LetLineZP(zpat, _, _) => extract_cursor_pat_term(zpat) + | LetLineZA(_, ztyp, _) => extract_cursor_type_term(ztyp) + | LetLineZE(_, _, zexp) => extract_cursor_exp_term(zexp) + }; +} +and extract_from_zexp_operand = + (zexp_operand: ZExp.zoperand): option(cursor_term) => { + switch (zexp_operand) { + | CursorE(cursor_pos, operand) => Some(Exp(cursor_pos, operand)) + | ParenthesizedZ(zexp) => extract_cursor_exp_term(zexp) + | LamZP(_, zpat, _, _) => extract_cursor_pat_term(zpat) + | LamZA(_, _, ztyp, _) => extract_cursor_type_term(ztyp) + | LamZE(_, _, _, zexp) + | InjZ(_, _, zexp) + | CaseZE(_, zexp, _, _) => extract_cursor_exp_term(zexp) + | CaseZR(_, _, zrules, _) => extract_from_zrules(zrules) + | CaseZA(_, _, _, ztyp) => extract_cursor_type_term(ztyp) + | ApPaletteZ(_, _, _, _) => failwith("ApPalette is not implemented") + }; +} +and extract_from_zrules = (zrules: ZExp.zrules): option(cursor_term) => { + let zrule = ZList.prj_z(zrules); + switch (zrule) { + | CursorR(cursor_pos, uex_rule) => Some(Rule(cursor_pos, uex_rule)) + | RuleZP(zpat, _) => extract_cursor_pat_term(zpat) + | RuleZE(_, zexp) => extract_cursor_exp_term(zexp) + }; +} +and extract_from_zexp_opseq = (zopseq: ZExp.zopseq): option(cursor_term) => { + switch (zopseq) { + | ZOpSeq(_, zseq) => + switch (zseq) { + | ZOperand(zoperand, _) => extract_from_zexp_operand(zoperand) + | ZOperator(zoperator, _) => + let (cursor_pos, uop) = zoperator; + Some(ExpOp(cursor_pos, uop)); + } + }; +} +and extract_cursor_pat_term = (zpat: ZPat.t): option(cursor_term) => { + switch (zpat) { + | ZOpSeq(_, zseq) => + switch (zseq) { + | ZOperand(zpat_operand, _) => extract_from_zpat_operand(zpat_operand) + | ZOperator(zpat_operator, _) => + let (cursor_pos, uop) = zpat_operator; + Some(PatOp(cursor_pos, uop)); + } + }; +} +and extract_from_zpat_operand = + (zpat_operand: ZPat.zoperand): option(cursor_term) => { + switch (zpat_operand) { + | CursorP(cursor_pos, upat_operand) => Some(Pat(cursor_pos, upat_operand)) + | ParenthesizedZ(zpat) + | InjZ(_, _, zpat) => extract_cursor_pat_term(zpat) + }; +} +and extract_cursor_type_term = (ztyp: ZTyp.t): option(cursor_term) => { + switch (ztyp) { + | ZOpSeq(_, zseq) => + switch (zseq) { + | ZOperand(ztyp_operand, _) => extract_from_ztyp_operand(ztyp_operand) + | ZOperator(ztyp_operator, _) => + let (cursor_pos, uop) = ztyp_operator; + Some(TypOp(cursor_pos, uop)); + } + }; +} +and extract_from_ztyp_operand = + (ztyp_operand: ZTyp.zoperand): option(cursor_term) => { + switch (ztyp_operand) { + | CursorT(cursor_pos, utyp_operand) => Some(Typ(cursor_pos, utyp_operand)) + | ParenthesizedZ(ztyp) + | ListZ(ztyp) => extract_cursor_type_term(ztyp) + }; +}; + +let can_group_cursor_term = + (cursor_term_1: option(cursor_term), cursor_term_2: option(cursor_term)) + : bool => { + switch (cursor_term_1, cursor_term_2) { + | (None, _) + | (_, None) => false + | (Some(cur1), Some(cur2)) => + switch (cur1, cur2) { + | (Exp(_, op1), Exp(_, op2)) => UHExp.can_group_operand(op1, op2) + | (Pat(_, op1), Pat(_, op2)) => UHPat.can_group_operand(op1, op2) + | (Line(_, line1), Line(_, line2)) => + UHExp.can_group_lines(line1, line2) + | (Exp(_, _), _) + | (Pat(_, _), _) + | (Typ(_, _), _) + | (ExpOp(_, _), _) + | (PatOp(_, _), _) + | (TypOp(_, _), _) + | (Line(_, _), _) + | (Rule(_, _), _) => false + } + }; +}; +let is_hole = (cursor_term: option(cursor_term)): bool => { + switch (cursor_term) { + | None => false + | Some(cursor_term') => + switch (cursor_term') { + | Exp(_, exp) => UHExp.operand_is_hole(exp) + | Pat(_, pat) => UHPat.operand_is_hole(pat) + | Typ(_, typ) => UHTyp.operand_is_hole(typ) + | ExpOp(_, _) + | PatOp(_, _) + | TypOp(_, _) + | Line(_, _) + | Rule(_, _) => false + } + }; +}; + +let get_cursor_pos = (cursor_term: cursor_term) => { + switch (cursor_term) { + | Exp(cursor_pos, _) + | Pat(cursor_pos, _) + | Typ(cursor_pos, _) + | ExpOp(cursor_pos, _) + | PatOp(cursor_pos, _) + | TypOp(cursor_pos, _) + | Line(cursor_pos, _) + | Rule(cursor_pos, _) => cursor_pos + }; +}; let mk = (~uses=?, typed, ctx) => {typed, ctx, uses}; let get_ctx = ci => ci.ctx; diff --git a/src/hazelcore/semantics/ErrStatus.re b/src/hazelcore/semantics/ErrStatus.re index 3af6525abc..6d1b25e356 100644 --- a/src/hazelcore/semantics/ErrStatus.re +++ b/src/hazelcore/semantics/ErrStatus.re @@ -4,9 +4,8 @@ module HoleReason = { type t = | TypeInconsistent | WrongLength; -}; +} /* Variable: `err` */; -/* Variable: `err` */ [@deriving sexp] type t = | NotInHole diff --git a/src/hazelcore/semantics/Monads.re b/src/hazelcore/semantics/Monads.re index 44533a6bfb..26921cb278 100644 --- a/src/hazelcore/semantics/Monads.re +++ b/src/hazelcore/semantics/Monads.re @@ -1,10 +1,10 @@ /* TODO: we might want to just use this API? - https://github.com/rgrinberg/ocaml-mtl/blob/master/lib/mtl.ml + https://github.com/rgrinberg/ocaml-mtl/blob/master/lib/mtl.ml - Though it's a bit heavy, especially with the extra type parameter... + Though it's a bit heavy, especially with the extra type parameter... - In any case, that's a good reference. */ + In any case, that's a good reference. */ module type MONAD = { [@deriving sexp] diff --git a/src/hazelcore/semantics/Seq.re b/src/hazelcore/semantics/Seq.re index 2d3cdc5227..6caf1693ee 100644 --- a/src/hazelcore/semantics/Seq.re +++ b/src/hazelcore/semantics/Seq.re @@ -1,256 +1,246 @@ -// TODO -// type t('operand, 'operator) = -// | S('operand, affix('operator, 'operand)) -// and affix('operator, 'operand) = option('operator, t('operand, 'operator)) -/** - * An unassociated infix operator sequence. - * Also used to represent the prefix or suffix - * of a selected operator in a seq, in both - * cases such that the head operand neighbors - * the selected operator. - */ -[@deriving sexp] -type t('operand, 'operator) = - /* Seq */ - | S('operand, affix('operand, 'operator)) -/** - * An unassociated infix operator sequence - * without a head operand. Used to represent - * the prefix or suffix of a selected operand - * in a seq, in both cases such that the head - * operator neighbors the selected operand. - */ -and affix('operand, 'operator) = - /* Empty */ - | E - /* Affix */ - | A('operator, t('operand, 'operator)); - -let rec mk_affix = - (op_pairs: list(('operator, 'operand))): affix('operand, 'operator) => - switch (op_pairs) { - | [] => E - | [(op, operand), ...rest] => A(op, S(operand, mk_affix(rest))) - }; -let mk = - (hd: 'operand, tl: list(('operator, 'operand))): t('operand, 'operator) => - S(hd, mk_affix(tl)); - -let rev = (seq: t('operand, 'operator)): t('operand, 'operator) => { - let rec rev_t = (rev: affix(_, _), seq) => { - let S(hd, tl) = seq; - rev_affix(S(hd, rev), tl); - } - and rev_affix = (rev: t(_, _), affix) => - switch (affix) { - | E => rev - | A(op, seq) => rev_t(A(op, rev), seq) - }; - rev_t(E, seq); -}; - -let rec affix_affix = - ( - affix1: affix('operand, 'operator), - affix2: affix('operand, 'operator), - ) - : affix('operand, 'operator) => - switch (affix1) { - | E => affix2 - | A(op, S(hd, tl)) => A(op, S(hd, affix_affix(tl, affix2))) - }; - -let seq_op_seq = - ( - seq1: t('operand, 'operator), - op: 'operator, - seq2: t('operand, 'operator), - ) - : t('operand, 'operator) => { - let S(hd1, tl1) = seq1; - S(hd1, affix_affix(tl1, A(op, seq2))); -}; - -let affix_seq = - (prefix: affix('operand, 'operator), seq: t('operand, 'operator)) - : t('operand, 'operator) => - switch (prefix) { - | E => seq - | A(op, affix_seq) => seq_op_seq(affix_seq |> rev, op, seq) - }; - -let seq_affix = - (seq: t('operand, 'operator), suffix: affix('operand, 'operator)) - : t('operand, 'operator) => - switch (suffix) { - | E => seq - | A(op, suffix_seq) => seq_op_seq(seq, op, suffix_seq) - }; - -/** - * Returns the number of operands. - */ -let rec length = - fun - | S(_, tail) => 1 + length_of_affix(tail) -and length_of_affix = - fun - | E => 0 - | A(_, seq) => length(seq); - -/** - * Returns the nth operand in seq if it exists, - * otherwise raises `Invalid_argument` - */ -let rec nth_operand = (n: int, seq: t('operand, _)): 'operand => { - let S(hd, tl) = seq; - n === 0 ? hd : tl |> nth_operand_of_affix(n - 1); -} -and nth_operand_of_affix = (n: int, affix: affix('operand, _)): 'operand => - switch (affix) { - | E => raise(Invalid_argument("Seq.nth_operand_of_affix")) - | A(_, seq) => seq |> nth_operand(n) - }; - -let operands_in_range = - ((a, b): (int, int), seq: t('operand, _)): list('operand) => - ListUtil.range(~lo=a, b + 1) |> List.map(n => seq |> nth_operand(n)); - -let rec operands = - fun - | S(hd, tl) => [hd, ...operands_of_affix(tl)] -and operands_of_affix = - fun - | E => [] - | A(_, seq) => operands(seq); - -/* - let rec join = (operands: ListMinTwo.t('operand), op: 'op): t('operand, 'op) => - switch (operands) { - | Pair(operand1, operand2) => Operand(operand1, op, operand2) - | Cons(operand, operands) => operand_op_seq(operand, op, join(operands, op)) - }; - */ - -let rec operators = - fun - | S(_, tl) => operators_of_affix(tl) -and operators_of_affix = - fun - | E => [] - | A(op, seq) => [op, ...operators(seq)]; - -/* update the nth operand in seq, if it exists */ -let rec opt_update_nth_operand = - (n: int, operand: 'operand, seq: t('operand, 'operator)) - : option(t('operand, 'operator)) => - if (n < 0 || n >= length(seq)) { - None; - } else { - switch (n, seq) { - | (0, S(_, tl)) => Some(S(operand, tl)) - | (_, S(hd, tl)) => - tl - |> opt_update_nth_operand_of_affix(n - 1, operand) - |> OptUtil.map(affix => S(hd, affix)) - }; - } -and opt_update_nth_operand_of_affix = - (n: int, operand: 'operand, affix: affix('operand, 'operator)) - : option(affix('operand, 'operator)) => - switch (affix) { - | E => Some(E) - | A(op, seq) => - seq - |> opt_update_nth_operand(n, operand) - |> OptUtil.map(seq => A(op, seq)) - }; - -let update_nth_operand = - (n: int, operand: 'operand, seq: t('operand, 'operator)) - : t('operand, 'operator) => - switch (seq |> opt_update_nth_operand(n, operand)) { - | None => failwith("update_nth_operand: index out of bounds") - | Some(seq) => seq - }; - -[@deriving sexp] -type operand_surround('operand, 'operator) = ( - affix('operand, 'operator), - affix('operand, 'operator), -); -[@deriving sexp] -type operator_surround('operand, 'operator) = ( - t('operand, 'operator), - t('operand, 'operator), -); - -let rec opt_split_nth_operand = - (n: int, seq: t('operand, 'operator)) - : option(('operand, operand_surround('operand, 'operator))) => { - switch (n, seq) { - | (_, _) when n < 0 => None - | (0, S(hd, tl)) => Some((hd, (E, tl))) - | (_, S(_, E)) => None - | (_, S(hd, A(op, seq))) => - seq - |> opt_split_nth_operand(n - 1) - |> OptUtil.map(((found, (prefix, suffix))) => - (found, (affix_affix(prefix, A(op, S(hd, E))), suffix)) - ) - }; -}; -let split_nth_operand = - (n: int, seq: t('operand, 'operator)) - : ('operand, operand_surround('operand, 'operator)) => - switch (opt_split_nth_operand(n, seq)) { - | None => raise(Invalid_argument("Seq.split_nth_operand")) - | Some(result) => result - }; - -let rec opt_split_nth_operator = - (n: int, seq: t('operand, 'operator)) - : option(('operator, operator_surround('operand, 'operator))) => - switch (n, seq) { - | (_, _) when n < 0 => None - | (_, S(_, E)) => None - | (0, S(hd, A(op, seq))) => Some((op, (S(hd, E), seq))) - | (_, S(hd, A(op, seq))) => - seq - |> opt_split_nth_operator(n - 1) - |> OptUtil.map(((found, (prefix, suffix))) => - (found, (seq_affix(prefix, A(op, S(hd, E))), suffix)) - ) - }; -let split_nth_operator = - (n: int, seq: t('operand, 'operator)) - : ('operator, operator_surround('operand, 'operator)) => - switch (seq |> opt_split_nth_operator(n)) { - | None => raise(Invalid_argument("Seq.split_nth_operator")) - | Some(result) => result - }; - -let split_first_and_suffix = seq => { - let (first, (_, suffix)) = split_nth_operand(0, seq); - (first, suffix); -}; -let split_prefix_and_last = seq => { - let (last, (prefix, _)) = split_nth_operand(length(seq) - 1, seq); - (prefix, last); -}; - -let t_of_operand_and_surround = - ( - operand: 'operand, - (prefix, suffix): operand_surround('operand, 'operator), - ) - : t('operand, 'operator) => - affix_seq(prefix, S(operand, suffix)); - -let t_of_operator_and_surround = - ( - operator: 'operator, - (prefix, suffix): operator_surround('operand, 'operator), - ) - : t('operand, 'operator) => - affix_seq(A(operator, prefix), suffix); +// TODO +// type t('operand, 'operator) = +// | S('operand, affix('operator, 'operand)) +// and affix('operator, 'operand) = option('operator, t('operand, 'operator)) +/** + * An unassociated infix operator sequence. + * Also used to represent the prefix or suffix + * of a selected operator in a seq, in both + * cases such that the head operand neighbors + * the selected operator. + */ +[@deriving sexp] +type t('operand, 'operator) = + /* Seq */ + | S('operand, affix('operand, 'operator)) +/** + * An unassociated infix operator sequence + * without a head operand. Used to represent + * the prefix or suffix of a selected operand + * in a seq, in both cases such that the head + * operator neighbors the selected operand. + */ +and affix('operand, 'operator) = + /* Empty */ + | E /* Affix */ + | A('operator, t('operand, 'operator)); + +let rec mk_affix = + (op_pairs: list(('operator, 'operand))): affix('operand, 'operator) => + switch (op_pairs) { + | [] => E + | [(op, operand), ...rest] => A(op, S(operand, mk_affix(rest))) + }; +let mk = + (hd: 'operand, tl: list(('operator, 'operand))): t('operand, 'operator) => + S(hd, mk_affix(tl)); + +let rev = (seq: t('operand, 'operator)): t('operand, 'operator) => { + let rec rev_t = (rev: affix(_, _), seq) => { + let S(hd, tl) = seq; + rev_affix(S(hd, rev), tl); + } + and rev_affix = (rev: t(_, _), affix) => + switch (affix) { + | E => rev + | A(op, seq) => rev_t(A(op, rev), seq) + }; + rev_t(E, seq); +}; + +let rec affix_affix = + ( + affix1: affix('operand, 'operator), + affix2: affix('operand, 'operator), + ) + : affix('operand, 'operator) => + switch (affix1) { + | E => affix2 + | A(op, S(hd, tl)) => A(op, S(hd, affix_affix(tl, affix2))) + }; + +let seq_op_seq = + ( + seq1: t('operand, 'operator), + op: 'operator, + seq2: t('operand, 'operator), + ) + : t('operand, 'operator) => { + let S(hd1, tl1) = seq1; + S(hd1, affix_affix(tl1, A(op, seq2))); +}; + +let affix_seq = + (prefix: affix('operand, 'operator), seq: t('operand, 'operator)) + : t('operand, 'operator) => + switch (prefix) { + | E => seq + | A(op, affix_seq) => seq_op_seq(affix_seq |> rev, op, seq) + }; + +let seq_affix = + (seq: t('operand, 'operator), suffix: affix('operand, 'operator)) + : t('operand, 'operator) => + switch (suffix) { + | E => seq + | A(op, suffix_seq) => seq_op_seq(seq, op, suffix_seq) + }; + +/** + * Returns the number of operands. + */ +let rec length = + fun + | S(_, tail) => 1 + length_of_affix(tail) +and length_of_affix = + fun + | E => 0 + | A(_, seq) => length(seq); + +/** + * Returns the nth operand in seq if it exists, + * otherwise raises `Invalid_argument` + */ +let rec nth_operand = (n: int, seq: t('operand, _)): 'operand => { + let S(hd, tl) = seq; + n === 0 ? hd : tl |> nth_operand_of_affix(n - 1); +} +and nth_operand_of_affix = (n: int, affix: affix('operand, _)): 'operand => + switch (affix) { + | E => raise(Invalid_argument("Seq.nth_operand_of_affix")) + | A(_, seq) => seq |> nth_operand(n) + }; + +let operands_in_range = + ((a, b): (int, int), seq: t('operand, _)): list('operand) => + ListUtil.range(~lo=a, b + 1) |> List.map(n => seq |> nth_operand(n)); + +let rec operands = + fun + | S(hd, tl) => [hd, ...operands_of_affix(tl)] +and operands_of_affix = + fun + | E => [] + | A(_, seq) => operands(seq) /* let rec join = (operands: ListMinTwo.t('operand), op: 'op): t('operand, 'op) => switch (operands) { | Pair(operand1, operand2) => Operand(operand1, op, operand2) | Cons(operand, operands) => operand_op_seq(operand, op, join(operands, op)) }; */; + +let rec operators = + fun + | S(_, tl) => operators_of_affix(tl) +and operators_of_affix = + fun + | E => [] + | A(op, seq) => [op, ...operators(seq)] /* update the nth operand in seq, if it exists */; + +let rec opt_update_nth_operand = + (n: int, operand: 'operand, seq: t('operand, 'operator)) + : option(t('operand, 'operator)) => + if (n < 0 || n >= length(seq)) { + None; + } else { + switch (n, seq) { + | (0, S(_, tl)) => Some(S(operand, tl)) + | (_, S(hd, tl)) => + tl + |> opt_update_nth_operand_of_affix(n - 1, operand) + |> OptUtil.map(affix => S(hd, affix)) + }; + } +and opt_update_nth_operand_of_affix = + (n: int, operand: 'operand, affix: affix('operand, 'operator)) + : option(affix('operand, 'operator)) => + switch (affix) { + | E => Some(E) + | A(op, seq) => + seq + |> opt_update_nth_operand(n, operand) + |> OptUtil.map(seq => A(op, seq)) + }; + +let update_nth_operand = + (n: int, operand: 'operand, seq: t('operand, 'operator)) + : t('operand, 'operator) => + switch (seq |> opt_update_nth_operand(n, operand)) { + | None => failwith("update_nth_operand: index out of bounds") + | Some(seq) => seq + }; + +[@deriving sexp] +type operand_surround('operand, 'operator) = ( + affix('operand, 'operator), + affix('operand, 'operator), +); +[@deriving sexp] +type operator_surround('operand, 'operator) = ( + t('operand, 'operator), + t('operand, 'operator), +); + +let rec opt_split_nth_operand = + (n: int, seq: t('operand, 'operator)) + : option(('operand, operand_surround('operand, 'operator))) => { + switch (n, seq) { + | (_, _) when n < 0 => None + | (0, S(hd, tl)) => Some((hd, (E, tl))) + | (_, S(_, E)) => None + | (_, S(hd, A(op, seq))) => + seq + |> opt_split_nth_operand(n - 1) + |> OptUtil.map(((found, (prefix, suffix))) => + (found, (affix_affix(prefix, A(op, S(hd, E))), suffix)) + ) + }; +}; +let split_nth_operand = + (n: int, seq: t('operand, 'operator)) + : ('operand, operand_surround('operand, 'operator)) => + switch (opt_split_nth_operand(n, seq)) { + | None => raise(Invalid_argument("Seq.split_nth_operand")) + | Some(result) => result + }; + +let rec opt_split_nth_operator = + (n: int, seq: t('operand, 'operator)) + : option(('operator, operator_surround('operand, 'operator))) => + switch (n, seq) { + | (_, _) when n < 0 => None + | (_, S(_, E)) => None + | (0, S(hd, A(op, seq))) => Some((op, (S(hd, E), seq))) + | (_, S(hd, A(op, seq))) => + seq + |> opt_split_nth_operator(n - 1) + |> OptUtil.map(((found, (prefix, suffix))) => + (found, (seq_affix(prefix, A(op, S(hd, E))), suffix)) + ) + }; +let split_nth_operator = + (n: int, seq: t('operand, 'operator)) + : ('operator, operator_surround('operand, 'operator)) => + switch (seq |> opt_split_nth_operator(n)) { + | None => raise(Invalid_argument("Seq.split_nth_operator")) + | Some(result) => result + }; + +let split_first_and_suffix = seq => { + let (first, (_, suffix)) = split_nth_operand(0, seq); + (first, suffix); +}; +let split_prefix_and_last = seq => { + let (last, (prefix, _)) = split_nth_operand(length(seq) - 1, seq); + (prefix, last); +}; + +let t_of_operand_and_surround = + ( + operand: 'operand, + (prefix, suffix): operand_surround('operand, 'operator), + ) + : t('operand, 'operator) => + affix_seq(prefix, S(operand, suffix)); + +let t_of_operator_and_surround = + ( + operator: 'operator, + (prefix, suffix): operator_surround('operand, 'operator), + ) + : t('operand, 'operator) => + affix_seq(A(operator, prefix), suffix); diff --git a/src/hazelcore/semantics/UHExp.re b/src/hazelcore/semantics/UHExp.re index 0370c75996..388f87ae22 100644 --- a/src/hazelcore/semantics/UHExp.re +++ b/src/hazelcore/semantics/UHExp.re @@ -319,3 +319,54 @@ let text_operand = u_gen, ); }; + +let can_group_operand = (op1: operand, op2: operand): bool => { + switch (op1, op2) { + | (EmptyHole(metavar1), EmptyHole(metavar2)) => metavar1 == metavar2 + | (Var(_, _, _), Var(_, _, _)) + | (NumLit(_, _), NumLit(_, _)) + | (BoolLit(_, _), BoolLit(_, _)) => true + | (EmptyHole(_), _) + | (Var(_, _, _), _) + | (NumLit(_, _), _) + | (BoolLit(_, _), _) + | (ListNil(_), _) + | (Lam(_, _, _, _), _) + | (Inj(_, _, _), _) + | (Case(_, _, _, _), _) + | (Parenthesized(_), _) => false + | (ApPalette(_, _, _, _), _) => failwith("ApPalette is not implemented") + }; +}; + +let can_group_lines = (line1: line, line2: line): bool => { + switch (line1, line2) { + | (EmptyLine, EmptyLine) => true + | (EmptyLine, _) + | (LetLine(_, _, _), _) + | (ExpLine(_), _) => false + }; +}; + +let operand_is_hole = (op: operand): bool => { + switch (op) { + | EmptyHole(_) => true + | Var(_, _, _) + | NumLit(_, _) + | BoolLit(_, _) + | ListNil(_) + | Lam(_, _, _, _) + | Inj(_, _, _) + | Case(_, _, _, _) + | Parenthesized(_) => false + | ApPalette(_, _, _, _) => failwith("ApPalette is not implemented") + }; +}; + +let is_empty_line = (line: line): bool => { + switch (line) { + | EmptyLine => true + | LetLine(_, _, _) + | ExpLine(_) => false + }; +}; diff --git a/src/hazelcore/semantics/UHPat.re b/src/hazelcore/semantics/UHPat.re index 2cf7ec8a6a..faca5c4347 100644 --- a/src/hazelcore/semantics/UHPat.re +++ b/src/hazelcore/semantics/UHPat.re @@ -167,3 +167,33 @@ let text_operand = u_gen, ); }; + +let can_group_operand = (op1: operand, op2: operand): bool => { + switch (op1, op2) { + | (EmptyHole(metavar1), EmptyHole(metavar2)) => metavar1 == metavar2 + | (Var(_, _, _), Var(_, _, _)) + | (NumLit(_, _), NumLit(_, _)) + | (BoolLit(_, _), BoolLit(_, _)) => true + | (EmptyHole(_), _) + | (Wild(_), _) + | (Var(_, _, _), _) + | (NumLit(_, _), _) + | (BoolLit(_, _), _) + | (ListNil(_), _) + | (Parenthesized(_), _) + | (Inj(_, _, _), _) => false + }; +}; + +let operand_is_hole = (op: operand): bool => { + switch (op) { + | EmptyHole(_) => true + | Wild(_) + | Var(_, _, _) + | NumLit(_, _) + | BoolLit(_, _) + | ListNil(_) + | Parenthesized(_) + | Inj(_, _, _) => false + }; +}; diff --git a/src/hazelcore/semantics/UHTyp.re b/src/hazelcore/semantics/UHTyp.re index b7e80426ca..39c8519d82 100644 --- a/src/hazelcore/semantics/UHTyp.re +++ b/src/hazelcore/semantics/UHTyp.re @@ -121,3 +121,27 @@ and expand_operand = | Bool => Bool | Parenthesized(opseq) => expand(opseq) | List(opseq) => List(expand(opseq)); + +let child_indices_operand = + fun + | Hole + | Unit + | Num + | Bool => [] + | Parenthesized(_) + | List(_) => [0]; +let child_indices_opseq: opseq => list(int) = + fun + | OpSeq(_, seq) => seq |> Seq.length |> ListUtil.range; +let child_indices = child_indices_opseq; + +let operand_is_hole = (op: operand) => { + switch (op) { + | Hole => true + | Unit + | Num + | Bool + | Parenthesized(_) + | List(_) => false + }; +}; diff --git a/src/hazelcore/semantics/Var.re b/src/hazelcore/semantics/Var.re index 1cba66f414..0dde9bdbf2 100644 --- a/src/hazelcore/semantics/Var.re +++ b/src/hazelcore/semantics/Var.re @@ -8,9 +8,8 @@ let eq = String.equal; let length = String.length; let valid_regex = Re.Str.regexp("^[_a-z][_a-zA-Z0-9']*$"); -let is_valid = s => Re.Str.string_match(valid_regex, s, 0); +let is_valid = s => Re.Str.string_match(valid_regex, s, 0) /* helper function for guarding options with is_valid */; -/* helper function for guarding options with is_valid */ let check_valid = (s, result) => if (is_valid(s)) { result; diff --git a/src/hazelcore/semantics/VarErrStatus.re b/src/hazelcore/semantics/VarErrStatus.re index e64da4a4e2..45b73beeed 100644 --- a/src/hazelcore/semantics/VarErrStatus.re +++ b/src/hazelcore/semantics/VarErrStatus.re @@ -1,13 +1,13 @@ module HoleReason = { /* Variable: reason */ // TODO rename Keyword to ExpandingKeyword + [@deriving sexp] type t = | Free | Keyword(ExpandingKeyword.t); -}; +} /* Variable: var_err */; -/* Variable: var_err */ [@deriving sexp] type t = | NotInVarHole diff --git a/src/hazelcore/semantics/palettes/PaletteCtx.re b/src/hazelcore/semantics/palettes/PaletteCtx.re index b7afbd9986..fd07f8369d 100644 --- a/src/hazelcore/semantics/palettes/PaletteCtx.re +++ b/src/hazelcore/semantics/palettes/PaletteCtx.re @@ -1,6 +1,5 @@ [@deriving sexp] type t = VarMap.t_(PaletteDefinition.t); -include VarMap; +include VarMap /* TODO added to handle removing option return type from fix_holes functions */; -/* TODO added to handle removing option return type from fix_holes functions */ exception InvalidPaletteHoleName; diff --git a/src/hazelcore/semantics/palettes/SpliceGenMonad.re b/src/hazelcore/semantics/palettes/SpliceGenMonad.re index dbdacf4555..09591daf0d 100644 --- a/src/hazelcore/semantics/palettes/SpliceGenMonad.re +++ b/src/hazelcore/semantics/palettes/SpliceGenMonad.re @@ -9,8 +9,7 @@ let bind = (cmd, f, psi) => { let exec = (cmd, psi, u_gen) => { let (a, psi) = cmd(psi); (a, psi, u_gen); -}; +} /* Have to add these functions to stub ppx_deriving.show for types that use this type */; -/* Have to add these functions to stub ppx_deriving.show for types that use this type */ let pp = (_, _, _) => (); let show = _ => "SpliceGenMonad"; diff --git a/src/hazelcore/semantics/palettes/SpliceGenMonad.rei b/src/hazelcore/semantics/palettes/SpliceGenMonad.rei index cc66a04174..eca5a6cbef 100644 --- a/src/hazelcore/semantics/palettes/SpliceGenMonad.rei +++ b/src/hazelcore/semantics/palettes/SpliceGenMonad.rei @@ -2,8 +2,7 @@ include Monads.MONAD; let exec: (t('a), SpliceInfo.t(UHExp.t), MetaVarGen.t) => - ('a, SpliceInfo.t(UHExp.t), MetaVarGen.t); + ('a, SpliceInfo.t(UHExp.t), MetaVarGen.t) /* Have to add these functions to stub ppx_deriving.show for types that use this type */; -/* Have to add these functions to stub ppx_deriving.show for types that use this type */ let pp: ('a, 'b, 'c) => unit; let show: t('a) => string; diff --git a/src/hazelcore/util/ZList.re b/src/hazelcore/util/ZList.re index eb6aa011f2..ed3ad76391 100644 --- a/src/hazelcore/util/ZList.re +++ b/src/hazelcore/util/ZList.re @@ -116,3 +116,28 @@ let shift_prev = (zxs: t('a, 'a)): option(t('a, 'a)) => { Some((List.rev(rev_prefix), prev, suffix)); }; }; +let shift_end = (zxs: t('a, 'a)): t('a, 'a) => { + let (prefix, z, suffix) = zxs; + switch (List.rev(suffix)) { + | [] => zxs + | [last_elt, ...tail] => + let prefix = prefix @ [z] @ List.rev(tail); + (prefix, last_elt, []); + }; +}; + +let shift_begin = (zxs: t('a, 'a)): t('a, 'a) => { + let (prefix, z, suffix) = zxs; + switch (prefix) { + | [] => zxs + | [head, ...tail] => + let suffix = tail @ [z] @ suffix; + ([], head, suffix); + }; +}; + +let shift_to = (n: int, xs: t('a, 'a)): option(t('a, 'a)) => { + let (prefix, z, suffix) = xs; + let lst = prefix @ [z, ...suffix]; + split_at(n, lst); +}; diff --git a/src/hazelcore/util/ZNatMap.re b/src/hazelcore/util/ZNatMap.re index d5429f10bb..4fb3351619 100644 --- a/src/hazelcore/util/ZNatMap.re +++ b/src/hazelcore/util/ZNatMap.re @@ -1,24 +1,22 @@ -open Sexplib.Std; - -/* Zippered finite map over nats, used with Z expressions - * i.e. there is a selected element of type Z and the rest is a int map of type A */ -[@deriving sexp] -type t('a, 'z) = (NatMap.t('a), (int, 'z)); -let make = (m: NatMap.t('a), (n, _) as nz: (int, 'z)): option(t('a, 'z)) => - switch (NatMap.lookup(m, n)) { - | Some(_) => None - | None => Some((m, nz)) - }; -let erase = (zmap: t('a, 'z), erase: 'z => 'a) => { - let (map', (n, z)) = zmap; - NatMap.insert_or_update(map', (n, erase(z))); -}; -let prj_map = ((map, _): t('a, 'z)): NatMap.t('a) => map; -let prj_z_kv = (zmap: t('a, 'z)): (int, 'z) => { - let (_, nz) = zmap; - nz; -}; -let prj_z_v = (zmap: t('a, 'z)): 'z => { - let (_, (_, z)) = zmap; - z; -}; +open Sexplib.Std /* Zippered finite map over nats, used with Z expressions * i.e. there is a selected element of type Z and the rest is a int map of type A */; + +[@deriving sexp] +type t('a, 'z) = (NatMap.t('a), (int, 'z)); +let make = (m: NatMap.t('a), (n, _) as nz: (int, 'z)): option(t('a, 'z)) => + switch (NatMap.lookup(m, n)) { + | Some(_) => None + | None => Some((m, nz)) + }; +let erase = (zmap: t('a, 'z), erase: 'z => 'a) => { + let (map', (n, z)) = zmap; + NatMap.insert_or_update(map', (n, erase(z))); +}; +let prj_map = ((map, _): t('a, 'z)): NatMap.t('a) => map; +let prj_z_kv = (zmap: t('a, 'z)): (int, 'z) => { + let (_, nz) = zmap; + nz; +}; +let prj_z_v = (zmap: t('a, 'z)): 'z => { + let (_, (_, z)) = zmap; + z; +}; diff --git a/src/hazelweb/JSUtil.re b/src/hazelweb/JSUtil.re index ca7c655144..b91efda7dc 100644 --- a/src/hazelweb/JSUtil.re +++ b/src/hazelweb/JSUtil.re @@ -159,7 +159,17 @@ let set_caret = (anchorNode, offset) => { assert(false); }; }; - +/* This comment part tries to make scrollbar follow the selected entry in history panel + However, "container##scrollTop=scroll_to##offsetTop;" will report an error + though it works in Js + I leave it here and wonder if Cyrus has any idea. + ----Zoe + */ +/* let scroll_anchor = (container_id, anchor_id) => { + let container = Dom_html.document##getElementById(Js.string(container_id)); + let scroll_to = Dom_html.document##getElementById(Js.string(anchor_id)); + container##scrollTop=scroll_to##offsetTop; + }; */ let reset_caret = () => { let selection = Dom_html.window##getSelection; if (selection##.rangeCount <= 0) { diff --git a/src/hazelweb/Palettes.re b/src/hazelweb/Palettes.re index ef7d70dc5a..8770b47d83 100644 --- a/src/hazelweb/Palettes.re +++ b/src/hazelweb/Palettes.re @@ -1,401 +1,82 @@ -module Dom_html = Js_of_ocaml.Dom_html; -module Dom = Js_of_ocaml.Dom; -module Js = Js_of_ocaml.Js; -module Vdom = Virtual_dom.Vdom; - -type div_type = Vdom.Node.t; - -module HTMLWithCells = { - type m_html_with_cells = - | NewCellFor(SpliceInfo.splice_name) - | Bind(m_html_with_cells, div_type => m_html_with_cells) - | Ret(div_type); -}; - -type view_type = - | Inline(Vdom.Node.t) - | MultiLine(HTMLWithCells.m_html_with_cells); - -module type PALETTE = { - let name: string; - let expansion_ty: HTyp.t; - - type model; - let init_model: SpliceGenMonad.t(model); - - type model_updater = model => unit; - /* model_updater must _not_ be invoked until well after view has completed */ - let view: (model, model_updater) => view_type; - - let expand: model => UHExp.t; - - let serialize: model => SerializedModel.t; - let deserialize: SerializedModel.t => model; -}; - -/* - module PairPalette: PALETTE = { - let name = "$pair"; - let expansion_ty = HTyp.(Arrow(Arrow(Hole, Arrow(Hole, Hole)), Hole)); - - type model = (int, int); - let init_model = (0, 0); /* TODO Fix me */ - type model_updater = model => unit; - - let view = ((leftID, rightID), model_updater) => - MultiLine( - HTMLWithCells.Bind( - HTMLWithCells.NewCellFor(leftID), - left_cell_div => - HTMLWithCells.Bind( - HTMLWithCells.NewCellFor(rightID), - right_cell_div => - HTMLWithCells.Ret( - Html5.( - div( - ~a=[a_class(["inline-div"])], - [left_cell_div, right_cell_div], - ) - ), - ), - ), - ), - ); - - let expand = ((leftID, rightID)) => { - let to_uhvar = id => - UHExp.( - Tm( - NotInHole, - Var(NotInVarHole, PaletteHoleData.mk_hole_ref_var_name(id)), - ) - ); - let fVarName = "f"; - let fVarPat = UHPat.Pat(NotInHole, UHPat.Var(fVarName)); - let apOpSeq = - UHExp.( - Seq.( - operand_op_seq( - Tm(NotInHole, Var(NotInVarHole, fVarName)), - Space, - ExpOpExp(to_uhvar(leftID), Space, to_uhvar(rightID)), - ) - ) - ); - UHExp.( - Tm( - NotInHole, - Lam( - fVarPat, - None, - Tm( - NotInHole, - UHExp.OpSeq(Associator.Exp.associate(apOpSeq), apOpSeq), - ), - ), - ) - ); - }; - - /* sprintf/sscanf are magical and treat string literals specially - - attempt to factor out the format string at your own peril */ - let serialize = ((leftID, rightID)) => - sprintf("(%d,%d)", leftID, rightID); - let deserialize = serialized => - sscanf(serialized, "(%d,%d)", (leftID, rightID) => (leftID, rightID)); - }; - - module ColorPalette: PALETTE = { - let name = "$color"; - let expansion_ty = - HTyp.(Arrow(Arrow(Num, Arrow(Num, Arrow(Num, Hole))), Hole)); - - type model = string; - let init_model = UHExp.HoleRefs.Ret("#c94d4d"); - - type model_updater = model => unit; - - let colors = [ - "#c94d4d", - "#d8832b", - "#dab71f", - "#446648", - "#165f99", - "#242551", - ]; - - let view = (model, model_updater) => { - let mk_color_elt = (color, selected_color) => { - let selected = color == selected_color ? ["selected"] : []; - Html5.( - div( - ~a=[ - a_class(["color", ...selected]), - a_style("background-color:" ++ color), - ], - [], - ) - ); - }; - - let color_elts = List.map(c => mk_color_elt(c, model), colors); - let _ = - List.map2( - (c, elt) => { - let elt_dom = Tyxml_js.To_dom.of_div(elt); - JSUtil.listen_to( - Dom_html.Event.click, - elt_dom, - _ => { - model_updater(c); - Js._true; - }, - ); - }, - colors, - color_elts, - ); - - let picker = Html5.(div(~a=[a_class(["color-picker"])], color_elts)); - MultiLine(HTMLWithCells.Ret(picker)); - }; - - let expand = rgb_hex => { - let to_decimal = hex => int_of_string("0x" ++ hex); - let (r, g, b) = - sscanf(rgb_hex, "#%.2s%.2s%.2s", (r, g, b) => - (to_decimal(r), to_decimal(g), to_decimal(b)) - ); - let fVarName = "f"; - let fPat = UHPat.(Pat(NotInHole, Var(fVarName))); - let r_num = UHExp.(Tm(NotInHole, NumLit(r))); - let g_num = UHExp.(Tm(NotInHole, NumLit(g))); - let b_num = UHExp.(Tm(NotInHole, NumLit(b))); - let body = - UHExp.( - Seq.( - operand_op_seq( - Tm(NotInHole, Var(NotInVarHole, fVarName)), - Space, - operand_op_seq(r_num, Space, ExpOpExp(g_num, Space, b_num)), - ) - ) - ); - UHExp.( - Tm( - NotInHole, - Lam( - fPat, - None, - Tm(NotInHole, OpSeq(Associator.Exp.associate(body), body)), - ), - ) - ); - }; - - let serialize = model => model; - let deserialize = serialized => serialized; - }; - - module CheckboxPalette: PALETTE = { - let name = "$checkbox"; - let expansion_ty = HTyp.Sum(HTyp.Num, HTyp.Num); - - type model = bool; - let init_model = UHExp.HoleRefs.Ret(false); - type model_updater = model => unit; - - let view = (model, model_updater) => { - let checked_state = model ? [Html5.a_checked()] : []; - let input_elt = - Html5.(input(~a=[a_input_type(`Checkbox), ...checked_state], ())); - let input_dom = Tyxml_js.To_dom.of_input(input_elt); - let view_span = Html5.(span([input_elt])); - let _ = - JSUtil.listen_to( - Dom_html.Event.input, - input_dom, - _ => { - let is_checked = Js.to_bool(input_dom##.checked); - model_updater(is_checked); - Js._true; - }, - ); - Inline(view_span); - }; - - let dummy_num = UHExp.Tm(NotInHole, UHExp.NumLit(0)); - let true_exp = UHExp.Tm(NotInHole, UHExp.Inj(L, dummy_num)); - let false_exp = UHExp.Tm(NotInHole, UHExp.Inj(R, dummy_num)); - let expand = model => model ? true_exp : false_exp; - - let serialize = model => model ? "T" : "F"; - let deserialize = serialized => - String.equal(serialized, "T") ? true : false; - }; - - /* overflow paranoia */ - let maxSliderValue = 1000 * 1000 * 1000; - let cropSliderValue = value => max(0, min(maxSliderValue, value)); - - module SliderPalette: PALETTE = { - let name = "$slider"; - let expansion_ty = HTyp.Num; - - type model = (int, int); - type model_updater = model => unit; - let init_model = UHExp.HoleRefs.Ret((5, 10)); - - let view = ((value, sliderMax), model_updater) => { - let curValString = curVal => Printf.sprintf("%d/%d", curVal, sliderMax); - let changeMaxButton = (desc, f) => - Html5.( - button( - ~a=[ - a_onclick(_ => { - let newSliderMax = f(sliderMax); - let newValue = min(value, newSliderMax); - model_updater((newValue, newSliderMax)); - true; - }), - ], - [txt(desc)], - ) - ); - let input_elt = - Html5.( - input( - ~a=[ - a_input_type(`Range), - a_input_min(`Number(0)), - a_input_max(`Number(cropSliderValue(sliderMax))), - a_value(string_of_int(cropSliderValue(value))), - ], - (), - ) - ); - let input_dom = Tyxml_js.To_dom.of_input(input_elt); - let label_elt = Html5.(label([txt(curValString(value))])); - let label_dom = Tyxml_js.To_dom.of_label(label_elt); - let decrease_range_button_elt = - changeMaxButton("/ 10", m => max(10, m / 10)); - let increase_range_button_elt = - changeMaxButton("* 10", m => cropSliderValue(m * 10)); - let view_span = - Html5.( - span([ - input_elt, - label_elt, - decrease_range_button_elt, - increase_range_button_elt, - ]) - ); - let _ = - JSUtil.listen_to( - Dom_html.Event.input, - input_dom, - _ => { - let _ = - label_dom##.innerHTML := - Js.string( - curValString( - int_of_string(Js.to_string(input_dom##.value)), - ), - ); - Js._true; - }, - ); - let _ = - JSUtil.listen_to( - Dom_html.Event.change, - input_dom, - _ => { - let newValue = - cropSliderValue(int_of_string(Js.to_string(input_dom##.value))); - model_updater((newValue, sliderMax)); - Js._true; - }, - ); - Inline(view_span); - }; - - let expand = ((value, _)) => - UHExp.Tm(NotInHole, UHExp.NumLit(cropSliderValue(value))); - - /* sprintf/sscanf are magical and treat string literals specially - - attempt to factor out the format string at your own peril */ - let serialize = ((value, sliderMax)) => - sprintf("(%d,%d)", value, sliderMax); - let deserialize = serialized => - sscanf(serialized, "(%d,%d)", (value, sliderMax) => (value, sliderMax)); - }; - */ -/* ---------- - stuff below is infrastructure - ---------- */ - -type model_updater = SerializedModel.t => unit; -type serialized_view_fn_t = (SerializedModel.t, model_updater) => view_type; - -module PaletteViewCtx = { - type t = VarMap.t_(serialized_view_fn_t); - include VarMap; -}; - -module PaletteContexts = { - type t = (PaletteCtx.t, PaletteViewCtx.t); - let empty = (PaletteViewCtx.empty, PaletteCtx.empty); - let extend: - (t, (PaletteName.t, PaletteDefinition.t, serialized_view_fn_t)) => t = - ((palette_ctx, palette_view_ctx), (name, defn, view_fn)) => { - let palette_view_ctx' = - PaletteViewCtx.extend(palette_view_ctx, (name, view_fn)); - let palette_ctx' = PaletteCtx.extend(palette_ctx, (name, defn)); - (palette_ctx', palette_view_ctx'); - }; -}; - -module PaletteAdapter = (P: PALETTE) => { - /* generate palette definition for Semantics */ - let palette_defn = - PaletteDefinition.{ - expansion_ty: P.expansion_ty, - init_model: SpliceGenMonad.return(""), - /* UHExp.HoleRefs.Bnd( - args = ( - P.init_model, - model => UHExp.HoleRefs.Ret(P.serialize(model)), - ), - ), */ - expand: serialized_model => P.expand(P.deserialize(serialized_model)), - }; - - let serialized_view_fn = (serialized_model, update_fn) => - P.view(P.deserialize(serialized_model), model => - update_fn(P.serialize(model)) - ); - - let contexts_entry = (P.name, palette_defn, serialized_view_fn); -}; -/* - module CheckboxPaletteAdapter = PaletteAdapter(CheckboxPalette); - module SliderPaletteAdapter = PaletteAdapter(SliderPalette); - module ColorPaletteAdapter = PaletteAdapter(ColorPalette); - module PairPaletteAdapter = PaletteAdapter(PairPalette); - */ -let empty_palette_contexts = PaletteContexts.empty; -let (initial_palette_ctx, initial_palette_view_ctx) = empty_palette_contexts; -/* - PaletteContexts.extend( - PaletteContexts.extend( - PaletteContexts.extend( - PaletteContexts.extend( - empty_palette_contexts, - CheckboxPaletteAdapter.contexts_entry, - ), - SliderPaletteAdapter.contexts_entry, - ), - ColorPaletteAdapter.contexts_entry, - ), - PairPaletteAdapter.contexts_entry, - ); */ +module Dom_html = Js_of_ocaml.Dom_html; +module Dom = Js_of_ocaml.Dom; +module Js = Js_of_ocaml.Js; +module Vdom = Virtual_dom.Vdom; + +type div_type = Vdom.Node.t; + +module HTMLWithCells = { + type m_html_with_cells = + | NewCellFor(SpliceInfo.splice_name) + | Bind(m_html_with_cells, div_type => m_html_with_cells) + | Ret(div_type); +}; + +type view_type = + | Inline(Vdom.Node.t) + | MultiLine(HTMLWithCells.m_html_with_cells); + +module type PALETTE = { + let name: string; + let expansion_ty: HTyp.t; + + type model; + let init_model: SpliceGenMonad.t(model); + + type model_updater = model => unit /* model_updater must _not_ be invoked until well after view has completed */; + let view: (model, model_updater) => view_type; + + let expand: model => UHExp.t; + + let serialize: model => SerializedModel.t; + let deserialize: SerializedModel.t => model /* module PairPalette: PALETTE = { let name = "$pair"; let expansion_ty = HTyp.(Arrow(Arrow(Hole, Arrow(Hole, Hole)), Hole)); type model = (int, int); let init_model = (0, 0); /* TODO Fix me */ type model_updater = model => unit; let view = ((leftID, rightID), model_updater) => MultiLine( HTMLWithCells.Bind( HTMLWithCells.NewCellFor(leftID), left_cell_div => HTMLWithCells.Bind( HTMLWithCells.NewCellFor(rightID), right_cell_div => HTMLWithCells.Ret( Html5.( div( ~a=[a_class(["inline-div"])], [left_cell_div, right_cell_div], ) ), ), ), ), ); let expand = ((leftID, rightID)) => { let to_uhvar = id => UHExp.( Tm( NotInHole, Var(NotInVarHole, PaletteHoleData.mk_hole_ref_var_name(id)), ) ); let fVarName = "f"; let fVarPat = UHPat.Pat(NotInHole, UHPat.Var(fVarName)); let apOpSeq = UHExp.( Seq.( operand_op_seq( Tm(NotInHole, Var(NotInVarHole, fVarName)), Space, ExpOpExp(to_uhvar(leftID), Space, to_uhvar(rightID)), ) ) ); UHExp.( Tm( NotInHole, Lam( fVarPat, None, Tm( NotInHole, UHExp.OpSeq(Associator.Exp.associate(apOpSeq), apOpSeq), ), ), ) ); }; /* sprintf/sscanf are magical and treat string literals specially - attempt to factor out the format string at your own peril */ let serialize = ((leftID, rightID)) => sprintf("(%d,%d)", leftID, rightID); let deserialize = serialized => sscanf(serialized, "(%d,%d)", (leftID, rightID) => (leftID, rightID)); }; module ColorPalette: PALETTE = { let name = "$color"; let expansion_ty = HTyp.(Arrow(Arrow(Num, Arrow(Num, Arrow(Num, Hole))), Hole)); type model = string; let init_model = UHExp.HoleRefs.Ret("#c94d4d"); type model_updater = model => unit; let colors = [ "#c94d4d", "#d8832b", "#dab71f", "#446648", "#165f99", "#242551", ]; let view = (model, model_updater) => { let mk_color_elt = (color, selected_color) => { let selected = color == selected_color ? ["selected"] : []; Html5.( div( ~a=[ a_class(["color", ...selected]), a_style("background-color:" ++ color), ], [], ) ); }; let color_elts = List.map(c => mk_color_elt(c, model), colors); let _ = List.map2( (c, elt) => { let elt_dom = Tyxml_js.To_dom.of_div(elt); JSUtil.listen_to( Dom_html.Event.click, elt_dom, _ => { model_updater(c); Js._true; }, ); }, colors, color_elts, ); let picker = Html5.(div(~a=[a_class(["color-picker"])], color_elts)); MultiLine(HTMLWithCells.Ret(picker)); }; let expand = rgb_hex => { let to_decimal = hex => int_of_string("0x" ++ hex); let (r, g, b) = sscanf(rgb_hex, "#%.2s%.2s%.2s", (r, g, b) => (to_decimal(r), to_decimal(g), to_decimal(b)) ); let fVarName = "f"; let fPat = UHPat.(Pat(NotInHole, Var(fVarName))); let r_num = UHExp.(Tm(NotInHole, NumLit(r))); let g_num = UHExp.(Tm(NotInHole, NumLit(g))); let b_num = UHExp.(Tm(NotInHole, NumLit(b))); let body = UHExp.( Seq.( operand_op_seq( Tm(NotInHole, Var(NotInVarHole, fVarName)), Space, operand_op_seq(r_num, Space, ExpOpExp(g_num, Space, b_num)), ) ) ); UHExp.( Tm( NotInHole, Lam( fPat, None, Tm(NotInHole, OpSeq(Associator.Exp.associate(body), body)), ), ) ); }; let serialize = model => model; let deserialize = serialized => serialized; }; module CheckboxPalette: PALETTE = { let name = "$checkbox"; let expansion_ty = HTyp.Sum(HTyp.Num, HTyp.Num); type model = bool; let init_model = UHExp.HoleRefs.Ret(false); type model_updater = model => unit; let view = (model, model_updater) => { let checked_state = model ? [Html5.a_checked()] : []; let input_elt = Html5.(input(~a=[a_input_type(`Checkbox), ...checked_state], ())); let input_dom = Tyxml_js.To_dom.of_input(input_elt); let view_span = Html5.(span([input_elt])); let _ = JSUtil.listen_to( Dom_html.Event.input, input_dom, _ => { let is_checked = Js.to_bool(input_dom##.checked); model_updater(is_checked); Js._true; }, ); Inline(view_span); }; let dummy_num = UHExp.Tm(NotInHole, UHExp.NumLit(0)); let true_exp = UHExp.Tm(NotInHole, UHExp.Inj(L, dummy_num)); let false_exp = UHExp.Tm(NotInHole, UHExp.Inj(R, dummy_num)); let expand = model => model ? true_exp : false_exp; let serialize = model => model ? "T" : "F"; let deserialize = serialized => String.equal(serialized, "T") ? true : false; }; /* overflow paranoia */ let maxSliderValue = 1000 * 1000 * 1000; let cropSliderValue = value => max(0, min(maxSliderValue, value)); module SliderPalette: PALETTE = { let name = "$slider"; let expansion_ty = HTyp.Num; type model = (int, int); type model_updater = model => unit; let init_model = UHExp.HoleRefs.Ret((5, 10)); let view = ((value, sliderMax), model_updater) => { let curValString = curVal => Printf.sprintf("%d/%d", curVal, sliderMax); let changeMaxButton = (desc, f) => Html5.( button( ~a=[ a_onclick(_ => { let newSliderMax = f(sliderMax); let newValue = min(value, newSliderMax); model_updater((newValue, newSliderMax)); true; }), ], [txt(desc)], ) ); let input_elt = Html5.( input( ~a=[ a_input_type(`Range), a_input_min(`Number(0)), a_input_max(`Number(cropSliderValue(sliderMax))), a_value(string_of_int(cropSliderValue(value))), ], (), ) ); let input_dom = Tyxml_js.To_dom.of_input(input_elt); let label_elt = Html5.(label([txt(curValString(value))])); let label_dom = Tyxml_js.To_dom.of_label(label_elt); let decrease_range_button_elt = changeMaxButton("/ 10", m => max(10, m / 10)); let increase_range_button_elt = changeMaxButton("* 10", m => cropSliderValue(m * 10)); let view_span = Html5.( span([ input_elt, label_elt, decrease_range_button_elt, increase_range_button_elt, ]) ); let _ = JSUtil.listen_to( Dom_html.Event.input, input_dom, _ => { let _ = label_dom##.innerHTML := Js.string( curValString( int_of_string(Js.to_string(input_dom##.value)), ), ); Js._true; }, ); let _ = JSUtil.listen_to( Dom_html.Event.change, input_dom, _ => { let newValue = cropSliderValue(int_of_string(Js.to_string(input_dom##.value))); model_updater((newValue, sliderMax)); Js._true; }, ); Inline(view_span); }; let expand = ((value, _)) => UHExp.Tm(NotInHole, UHExp.NumLit(cropSliderValue(value))); /* sprintf/sscanf are magical and treat string literals specially - attempt to factor out the format string at your own peril */ let serialize = ((value, sliderMax)) => sprintf("(%d,%d)", value, sliderMax); let deserialize = serialized => sscanf(serialized, "(%d,%d)", (value, sliderMax) => (value, sliderMax)); }; */ /* ---------- + stuff below is infrastructure + ---------- */; +}; + +type model_updater = SerializedModel.t => unit; +type serialized_view_fn_t = (SerializedModel.t, model_updater) => view_type; + +module PaletteViewCtx = { + type t = VarMap.t_(serialized_view_fn_t); + include VarMap; +}; + +module PaletteContexts = { + type t = (PaletteCtx.t, PaletteViewCtx.t); + let empty = (PaletteViewCtx.empty, PaletteCtx.empty); + let extend: + (t, (PaletteName.t, PaletteDefinition.t, serialized_view_fn_t)) => t = + ((palette_ctx, palette_view_ctx), (name, defn, view_fn)) => { + let palette_view_ctx' = + PaletteViewCtx.extend(palette_view_ctx, (name, view_fn)); + let palette_ctx' = PaletteCtx.extend(palette_ctx, (name, defn)); + (palette_ctx', palette_view_ctx'); + }; +}; + +module PaletteAdapter = (P: PALETTE) => { + /* generate palette definition for Semantics */ + let palette_defn = + PaletteDefinition.{ + expansion_ty: P.expansion_ty, + init_model: SpliceGenMonad.return("") /* UHExp.HoleRefs.Bnd( args = ( P.init_model, model => UHExp.HoleRefs.Ret(P.serialize(model)), ), ), */, + + expand: serialized_model => P.expand(P.deserialize(serialized_model)), + }; + + let serialized_view_fn = (serialized_model, update_fn) => + P.view(P.deserialize(serialized_model), model => + update_fn(P.serialize(model)) + ); + + let contexts_entry = (P.name, palette_defn, serialized_view_fn); +} /* + module CheckboxPaletteAdapter = PaletteAdapter(CheckboxPalette); + module SliderPaletteAdapter = PaletteAdapter(SliderPalette); + module ColorPaletteAdapter = PaletteAdapter(ColorPalette); + module PairPaletteAdapter = PaletteAdapter(PairPalette); + */; + +let empty_palette_contexts = PaletteContexts.empty; +let (initial_palette_ctx, initial_palette_view_ctx) = empty_palette_contexts /* PaletteContexts.extend( PaletteContexts.extend( PaletteContexts.extend( PaletteContexts.extend( empty_palette_contexts, CheckboxPaletteAdapter.contexts_entry, ), SliderPaletteAdapter.contexts_entry, ), ColorPaletteAdapter.contexts_entry, ), PairPaletteAdapter.contexts_entry, ); */; diff --git a/src/hazelweb/Update.re b/src/hazelweb/Update.re index 56c188c689..e1480fe730 100644 --- a/src/hazelweb/Update.re +++ b/src/hazelweb/Update.re @@ -27,7 +27,10 @@ module Action = { | BlurCell | FocusWindow | Redo - | Undo; + | Undo + | ShiftHistory(int, int) + | ToggleHistoryGroup(int) + | ToggleHiddenHistoryAll; }; [@deriving sexp] @@ -82,7 +85,10 @@ let log_action = (action: Action.t, _: State.t): unit => { | FocusWindow | MoveToHole(_) | Undo - | Redo => + | Redo + | ShiftHistory(_, _) + | ToggleHistoryGroup(_) + | ToggleHiddenHistoryAll => Logger.append( Sexp.to_string( sexp_of_timestamped_action(mk_timestamped_action(action)), @@ -185,15 +191,70 @@ let apply_action = }; model; - | Undo => - let new_history = UndoHistory.undo(model.undo_history); - let new_edit_state = ZList.prj_z(new_history); - let new_model = model |> Model.put_program(Program.mk(new_edit_state)); - {...new_model, undo_history: new_history}; - | Redo => - let new_history = UndoHistory.redo(model.undo_history); - let new_edit_state = ZList.prj_z(new_history); - let new_model = model |> Model.put_program(Program.mk(new_edit_state)); - {...new_model, undo_history: new_history}; + | Undo => Model.undo(model) + | Redo => Model.redo(model) + /* click the history panel to shift to the certain history entry */ + | ShiftHistory(group_id, elt_id) => + /* shift to the group with group_id */ + switch (ZList.shift_to(group_id, model.undo_history)) { + | None => failwith("Impossible match, because undo_history is non-empty") + | Some(new_history) => + let cur_group = ZList.prj_z(new_history); + /* shift to the element with elt_id */ + switch (ZList.shift_to(elt_id, cur_group.group_entries)) { + | None => failwith("Impossible because group_entries is non-empty") + | Some(new_group_entries) => + let new_cardstacks = ZList.prj_z(new_group_entries).cardstacks; + let new_model = model |> Model.put_cardstacks(new_cardstacks); + { + ...new_model, + undo_history: + ZList.replace_z( + {...cur_group, group_entries: new_group_entries}, + new_history, + ), + }; + }; + } + | ToggleHistoryGroup(toggle_group_id) => + let (suc_groups, _, _) = model.undo_history; + let cur_group_id = List.length(suc_groups); + /*shift to the toggle-target group and change its expanded state*/ + switch (ZList.shift_to(toggle_group_id, model.undo_history)) { + | None => failwith("Impossible match, because undo_history is non-empty") + | Some(history) => + let toggle_target_group = ZList.prj_z(history); + /* change expanded state of the toggle target group after toggling */ + let after_toggle = + ZList.replace_z( + { + ...toggle_target_group, + is_expanded: !toggle_target_group.is_expanded, + }, + history, + ); + /*shift back to the current group*/ + switch (ZList.shift_to(cur_group_id, after_toggle)) { + | None => + failwith("Impossible match, because undo_history is non-empty") + | Some(new_history) => {...model, undo_history: new_history} + }; + }; + | ToggleHiddenHistoryAll => + if (model.all_hidden_history_expand) { + { + ...model, + all_hidden_history_expand: false, + undo_history: + UndoHistory.set_all_hidden_history(model.undo_history, false), + }; + } else { + { + ...model, + all_hidden_history_expand: true, + undo_history: + UndoHistory.set_all_hidden_history(model.undo_history, true), + }; + } }; }; diff --git a/src/hazelweb/gui/Page.re b/src/hazelweb/gui/Page.re index 607a224b62..e8fc3a13f5 100644 --- a/src/hazelweb/gui/Page.re +++ b/src/hazelweb/gui/Page.re @@ -248,6 +248,7 @@ let page_view = [ CursorInspector.view(~inject, model), ContextInspector.view(~inject, model), + UndoHistoryPanel.view(~inject, model), OptionsPanel.view(~inject, model), ], ), diff --git a/src/hazelweb/gui/Panel.re b/src/hazelweb/gui/Panel.re index 5e6d0df5ff..c5964bcfe6 100644 --- a/src/hazelweb/gui/Panel.re +++ b/src/hazelweb/gui/Panel.re @@ -4,10 +4,9 @@ let view_of_main_title_bar = (title_text: string) => Vdom.( Node.div( [Attr.classes(["title-bar", "panel-title-bar"])], - [Node.text(title_text)], + [Node.text(title_text)] /* For title bars that appear mid-panel. These are styled differently. */, ) ); -/* For title bars that appear mid-panel. These are styled differently. */ let view_of_other_title_bar = (title_text: string) => Vdom.(Node.div([Attr.classes(["title-bar"])], [Node.text(title_text)])); diff --git a/src/hazelweb/gui/SvgShapes.re b/src/hazelweb/gui/SvgShapes.re index 33746584e1..310b47abc7 100644 --- a/src/hazelweb/gui/SvgShapes.re +++ b/src/hazelweb/gui/SvgShapes.re @@ -1,23 +1,16 @@ -open Incr_dom; - -/* Create an icon from a set of points with coords between 0 and 100. - * The actual size of the icon can be styled using a CSS class. - */ -let icon = (classes, _points) => - Vdom.Node.div([Vdom.Attr.classes(classes)], []); -/* TODO dunno how to get svg stuff working with incr_dom - Tyxml.( - Svg.svg( - ~a=[Svg.a_class(classes), Svg.a_viewBox((0.0, 0.0, 100.0, 100.0))], - [Svg.polygon(~a=[Svg.a_points(points)], [])], - ) - ); - */ - -/* Creating elements is side-effectful, so the extra - * parameter is to allow delaying their construction. - */ -let left_arrow = (classes: list(string), _: unit) => - icon(classes, [(0.0, 50.0), (100.0, 0.0), (100.0, 100.0)]); -let right_arrow = (classes: list(string), _: unit) => - icon(classes, [(0.0, 0.0), (100.0, 50.0), (0.0, 100.0)]); +open Incr_dom /* Create an icon from a set of points with coords between 0 and 100. * The actual size of the icon can be styled using a CSS class. */; + +let icon = (classes, _points) => + Vdom.Node.div([Vdom.Attr.classes(classes)], []) /* Creating elements is side-effectful, so the extra * parameter is to allow delaying their construction. */ /* TODO dunno how to get svg stuff working with incr_dom + Tyxml.( + Svg.svg( + ~a=[Svg.a_class(classes), Svg.a_viewBox((0.0, 0.0, 100.0, 100.0))], + [Svg.polygon(~a=[Svg.a_points(points)], [])], + ) + ); + */; + +let left_arrow = (classes: list(string), _: unit) => + icon(classes, [(0.0, 50.0), (100.0, 0.0), (100.0, 100.0)]); +let right_arrow = (classes: list(string), _: unit) => + icon(classes, [(0.0, 0.0), (100.0, 50.0), (0.0, 100.0)]); diff --git a/src/hazelweb/gui/UndoHistoryPanel.re b/src/hazelweb/gui/UndoHistoryPanel.re new file mode 100644 index 0000000000..c30d404a24 --- /dev/null +++ b/src/hazelweb/gui/UndoHistoryPanel.re @@ -0,0 +1,790 @@ +module Vdom = Virtual_dom.Vdom; +type undo_history_group = UndoHistory.undo_history_group; +type undo_history_entry = UndoHistory.undo_history_entry; + +let view = (~inject: Update.Action.t => Vdom.Event.t, model: Model.t) => { + /* a helper function working as an enhanced version of List.map() */ + let rec list_map_helper_func = (func_to_list, func_to_base, base, lst) => { + switch (lst) { + | [] => [] + | [head, ...tail] => [ + func_to_list(base, head), + ...list_map_helper_func( + func_to_list, + func_to_base, + func_to_base(base), + tail, + ), + ] + }; + }; + + let exp_str = (exp: UHExp.operand): string => { + switch (exp) { + | EmptyHole(meta_var) => "hole: " ++ string_of_int(meta_var) + | Var(_, _, var_str) => "var: " ++ var_str + | NumLit(_, num) => "number: " ++ string_of_int(num) + | BoolLit(_, bool_val) => "bool: " ++ string_of_bool(bool_val) + | ListNil(_) => "empty list" + | Lam(_, _, _, _) => "lambada function" + | Inj(_, inj_side, _) => "injection: " ++ InjSide.to_string(inj_side) + | Case(_, _, _, _) => "case match" + | Parenthesized(_) => "( )" + | ApPalette(_, _, _, _) => failwith("ApPalette is not implemented") + }; + }; + + let pat_str = (pat: UHPat.operand): string => { + switch (pat) { + | EmptyHole(meta_var) => "hole: " ++ string_of_int(meta_var) + | Wild(_) => "I don't know its meaning" + | Var(_, _, var_str) => "var: " ++ var_str + | NumLit(_, num) => "number: " ++ string_of_int(num) + | BoolLit(_, bool_val) => "bool: " ++ string_of_bool(bool_val) + | ListNil(_) => "empty list" + | Parenthesized(_) => "( )" + | Inj(_, inj_side, _) => "injection: " ++ InjSide.to_string(inj_side) + }; + }; + + let typ_str = (typ: UHTyp.operand): string => { + switch (typ) { + | Hole => "type: Hole" + | Unit => "type: Unit" + | Num => "type: Num" + | Bool => "type: Bool" + | Parenthesized(_) => "( )" + | List(_) => "[ ]" + }; + }; + let display_string_of_cursor = + (cursor_term: option(CursorInfo.cursor_term)): string => { + switch (cursor_term) { + | None => + failwith("Imposiible match, the inital state will not be displayed") + | Some(cursor_term') => + switch (cursor_term') { + | Exp(_, exp) => exp_str(exp) + | Pat(_, pat) => pat_str(pat) + | Typ(_, typ) => typ_str(typ) + | ExpOp(_, op) => UHExp.string_of_operator(op) + | PatOp(_, op) => UHPat.string_of_operator(op) + | TypOp(_, op) => UHTyp.string_of_operator(op) + | Line(_, line_content) => + switch (line_content) { + | EmptyLine => "empty line" + | LetLine(_, _, _) => "let binding" + | ExpLine(_) => "expression line" + } + | Rule(_, _) => "match rule" + } + }; + }; + let can_delete_typ_inf = (cursor_term: option(CursorInfo.cursor_term)) => { + switch (cursor_term) { + | None => + failwith("Imposiible match, the inital state will not be displayed") + | Some(cursor_term') => + switch (cursor_term') { + | Exp(_, exp) => + switch (exp) { + | EmptyHole(_) + | Var(_, _, _) + | NumLit(_, _) + | BoolLit(_, _) + | ListNil(_) + | Inj(_, _, _) + | Case(_, _, _, _) + | Parenthesized(_) => false + | Lam(_, _, _, _) => true + | ApPalette(_, _, _, _) => failwith("ApPalette is not implemented") + } + | Pat(_, _) + | Typ(_, _) + | ExpOp(_, _) + | PatOp(_, _) + | TypOp(_, _) => false + | Line(_, line_content) => + switch (line_content) { + | EmptyLine + | ExpLine(_) => false + | LetLine(_, _, _) => true + } + | Rule(_, _) => false + } + }; + }; + let string_of_history_entry = + (undo_history_entry: undo_history_entry): option(string) => { + let action = undo_history_entry.previous_action; + let prev_cursor_term = undo_history_entry.previous_cursor_term; + let cur_cursor_term = undo_history_entry.current_cursor_term; + let cur_cursor_pos = + switch (cur_cursor_term) { + | None => failwith("Imposiible match, cur_cursor is never None") + | Some(cursor_term') => CursorInfo.get_cursor_pos(cursor_term') + }; + let prev_cursor_pos = + switch (prev_cursor_term) { + | None => + failwith("Imposiible match, the inital state will not be displayed") + | Some(cursor_term') => CursorInfo.get_cursor_pos(cursor_term') + }; + switch (action) { + | None => None + | Some(action') => + switch (action') { + | MoveTo(_) + | MoveToBefore(_) + | MoveLeft + | MoveRight + | MoveToNextHole + | MoveToPrevHole => + failwith("Imposiible match, none of undoable actions will be matched") + | UpdateApPalette(_) => failwith("ApPalette is not implemented") + | Delete => + switch (prev_cursor_pos) { + | OnText(_) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | OnDelim(num, side) => + switch (side) { + | Before => + if (CursorInfo.is_hole(prev_cursor_term)) { + None; + } else if (num == 1 && can_delete_typ_inf(prev_cursor_term)) { + /* num==1 is the position of ':' in an expression */ + Some( + "clear type inference of " + ++ display_string_of_cursor(prev_cursor_term), + ); + } else { + Some(" clear " ++ display_string_of_cursor(prev_cursor_term)); + } + | After => + switch (cur_cursor_pos) { + | OnText(_) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | OnOp(side) + | OnDelim(_, side) => + switch (side) { + | Before => None + | After => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + } + } + } + | OnOp(side) => + switch (side) { + | Before => + Some("clear " ++ display_string_of_cursor(prev_cursor_term)) + | After => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + } + } + | Backspace => + switch (prev_cursor_pos) { + | OnText(_) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | OnDelim(num, side) => + switch (side) { + | Before => + switch (cur_cursor_pos) { + | OnText(_) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | OnOp(side) + | OnDelim(_, side) => + switch (side) { + | Before => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | After => None + } + } + + | After => + if (CursorInfo.is_hole(prev_cursor_term)) { + None; + } else if (num == 1 && can_delete_typ_inf(prev_cursor_term)) { + Some( + "clear type inference of " + ++ display_string_of_cursor(prev_cursor_term), + ); + } else { + Some(" clear " ++ display_string_of_cursor(prev_cursor_term)); + } + } + | OnOp(side) => + switch (side) { + | Before => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | After => + Some("clear " ++ display_string_of_cursor(prev_cursor_term)) + } + } + | Construct(shape) => + /* match for keyword */ + switch (shape) { + | SParenthesized => Some("add ( )") + | SList => Some("type List") + | SAsc => Some("type inference") + | SLam => Some("add lambada") + | SListNil => Some("add [ ]") + | SInj(direction) => + switch (direction) { + | L => Some("inject left") + | R => Some("inject right") + } + | SLet => Some("add let binding") + | SLine => Some("add new lines") + | SCase => Some("add case") + | SChar(_) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | SOp(shape') => + switch (shape') { + | SMinus + | SPlus + | STimes + | SLessThan + | SGreaterThan + | SEquals + | SComma + | SArrow + | SVBar + | SCons + | SAnd + | SOr => Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | SSpace => + switch (prev_cursor_term) { + | None => + failwith("Imposiible match, undisplayed undo history entry") + | Some(cursor_term') => + switch (cursor_term') { + | Exp(_, uexp_operand) => + switch (uexp_operand) { + | Var(_, InVarHole(Keyword(k), _), _) => + switch (k) { + | Let => Some("construct let binding") + | Case => Some("construct case match") + } + | EmptyHole(_) + | Var(_, _, _) + | NumLit(_, _) + | BoolLit(_, _) + | ListNil(_) + | Lam(_, _, _, _) + | Inj(_, _, _) + | Case(_, _, _, _) + | Parenthesized(_) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + | ApPalette(_, _, _, _) => + failwith("ApPalette is not implemented") + } + | Pat(_, _) + | Typ(_, _) + | ExpOp(_, _) + | PatOp(_, _) + | TypOp(_, _) + | Line(_, _) + | Rule(_, _) => + Some("edit " ++ display_string_of_cursor(cur_cursor_term)) + } + } + } + + | SApPalette(_) => failwith("ApPalette is not implemented") + } + } + }; + }; + + let display_string_of_history_entry = + (undo_history_entry: undo_history_entry): option(string) => { + let cur_cursor_term = undo_history_entry.current_cursor_term; + switch (string_of_history_entry(undo_history_entry)) { + | None => None + | Some(str) => + switch (cur_cursor_term) { + | None => failwith("Imposiible match, undisplayed undo history entry") + | Some(cursor_term) => + switch (cursor_term) { + | Exp(cursor_pos, exp) => + switch (exp) { + | EmptyHole(_) + | Var(_, _, _) + | NumLit(_, _) + | BoolLit(_, _) + | ListNil(_) => Some(str) + | Case(_, _, _, _) + | Lam(_, _, _, _) + | Parenthesized(_) + | Inj(_, _, _) => + switch (cursor_pos) { + | OnDelim(_, _) => None + | OnOp(_) + | OnText(_) => Some(str) + } + | ApPalette(_, _, _, _) => failwith("ApPalette is not implemented") + } + | Pat(cursor_pos, pat) => + switch (pat) { + | EmptyHole(_) + | Wild(_) + | Var(_, _, _) + | NumLit(_, _) + | BoolLit(_, _) + | ListNil(_) => Some(str) + | Parenthesized(_) + | Inj(_, _, _) => + switch (cursor_pos) { + | OnDelim(_, _) => None + | OnOp(_) + | OnText(_) => Some(str) + } + } + | Typ(_, _) + | ExpOp(_, _) + | PatOp(_, _) + | TypOp(_, _) => Some(str) + | Line(cursor_pos, _) + | Rule(cursor_pos, _) => + switch (cursor_pos) { + | OnDelim(_, _) => None + | OnOp(_) + | OnText(_) => Some(str) + } + } + } + }; + }; + let history_hidden_entry_view = + (group_id: int, elt_id: int, undo_history_entry: undo_history_entry) => { + switch (undo_history_entry.previous_action) { + | None => Vdom.(Node.div([], [])) /* entry in initial state should not be displayed */ + | Some(_) => + switch (display_string_of_history_entry(undo_history_entry)) { + | None => Vdom.(Node.div([], [])) + | Some(str) => + Vdom.( + Node.div( + [ + Attr.classes(["the-hidden-history-entry"]), + Attr.on_click(_ => + inject(Update.Action.ShiftHistory(group_id, elt_id)) + ), + ], + [Node.text(str)], + ) + ) + } + }; + }; + + let history_entry_tab_icon = + (group_id: int, has_hidden_part: bool, is_expanded: bool) => { + let icon_classes = + if (is_expanded) { + ["down-triangle", "history-tab-icon"]; + } else { + ["left-triangle", "history-tab-icon"]; + }; + if (has_hidden_part) { + /* expand icon*/ + Vdom.( + Node.div( + [ + Attr.classes(icon_classes), + Attr.on_click(_ => + inject(Update.Action.ToggleHistoryGroup(group_id)) + ), + ], + [], + ) + ); + } else { + /* no expand icon if there is no hidden part */ + Vdom.(Node.div([], [])); + }; + }; + + /* The entry which is always displayed*/ + let history_title_entry_view = + ( + ~is_expanded: bool, + ~has_hidden_part: bool, + group_id: int, + elt_id: int, + undo_history_entry: undo_history_entry, + ) => { + switch (undo_history_entry.previous_action) { + | None => Vdom.(Node.div([], [])) /* entry in the initial state should not be displayed */ + | Some(_) => + switch (display_string_of_history_entry(undo_history_entry)) { + | None => Vdom.(Node.div([], [])) + | Some(str) => + Vdom.( + Node.div( + [ + Attr.classes([ + "the-history-title", + "always-display-history-entry", + ]), + ], + [ + Node.div( + [Attr.classes(["the-history-title-entry"])], + [ + Node.span( + [ + Attr.classes(["the-history-title-txt"]), + Attr.on_click(_ => + inject(Update.Action.ShiftHistory(group_id, elt_id)) + ), + ], + [Node.text(str)], + ), + history_entry_tab_icon( + group_id, + has_hidden_part, + is_expanded, + ), + ], + ), + ], + ) + ) + } + }; + }; + + let group_view = + (~is_cur_group: bool, group_id: int, group: undo_history_group) => { + /* if the group containning selected history entry, it should be splited into different css styles */ + let suc_his_classes = + if (is_cur_group) { + ["the-suc-history"]; + } else { + []; + }; + let prev_his_classes = + if (is_cur_group) { + ["the-prev-history"]; + } else { + []; + }; + let cur_his_classes = + if (is_cur_group) { + ["the-cur-history"]; + } else { + []; + }; + switch (group.group_entries) { + | ([], cur_entry, prev_entries) => + switch (cur_entry.previous_action) { + | None => Vdom.(Node.div([], [])) /* the entry in intial state should not be displayed */ + | Some(_) => + let has_hidden_part = + switch (prev_entries) { + | [] => false + | _ => true + }; + if (group.is_expanded) { + Vdom.( + Node.div( + [Attr.classes(["the-history-group"])], + [ + /* title entry */ + Vdom.( + Node.div( + [Attr.classes(cur_his_classes)], + [ + history_title_entry_view( + ~is_expanded=group.is_expanded, + ~has_hidden_part, + group_id, + 0, /*elt_id*/ + cur_entry, + ), + ], + ) + ), + /* hidden entries */ + Vdom.( + Node.div( + [ + Attr.classes( + ["hidden-history-entry"] @ prev_his_classes, + ), + ], + list_map_helper_func( + history_hidden_entry_view(group_id), + base => base + 1, + 1, /* base elt_id is 1, because there is a title entry with elt_id=0 before */ + prev_entries, + ), + ) + ), + ], + ) + ); + } else { + /* if the group is not expanded, only title entry is displayed */ + Vdom.( + Node.div( + [Attr.classes(["the-history-group"])], + [ + Vdom.( + Node.div( + [Attr.classes(cur_his_classes)], + [ + history_title_entry_view( + ~is_expanded=group.is_expanded, + ~has_hidden_part, + group_id, + 0, /*elt_id*/ + cur_entry, + ), + ], + ) + ), + ], + ) + ); + }; + } + + | ([title_entry, ...suc_entries], cur_entry, prev_entries) => + if (group.is_expanded) { + Vdom.( + Node.div( + [Attr.classes(["the-history-group"])], + [ + /* the history title entry */ + Vdom.( + Node.div( + [Attr.classes(suc_his_classes)], + [ + history_title_entry_view( + ~is_expanded=group.is_expanded, + ~has_hidden_part=true, + group_id, + 0, /*elt_id*/ + title_entry, + ), + ], + ) + ), + /* the successor history entry */ + Vdom.( + Node.div( + [ + Attr.classes(["hidden-history-entry"] @ suc_his_classes), + ], + list_map_helper_func( + history_hidden_entry_view(group_id), + base => base + 1, + 1, /* base elt_id is 1, because there is a title entry with elt_id=0 ahead */ + suc_entries, + ), + ) + ), + /* the selected(current) history entry */ + Vdom.( + Node.div( + [ + Attr.classes(["hidden-history-entry"] @ cur_his_classes), + ], + [ + history_hidden_entry_view( + group_id, + List.length(suc_entries) + 1, /* elt_id */ + cur_entry, + ), + ], + ) + ), + /* the previous history entry */ + Vdom.( + Node.div( + [ + Attr.classes(["hidden-history-entry"] @ prev_his_classes), + ], + list_map_helper_func( + history_hidden_entry_view(group_id), + base => base + 1, + List.length(suc_entries) + 2, /* base elt_id */ + prev_entries, + ), + ) + ), + ], + ) + ); + } else { + Vdom.( + Node.div( + [Attr.classes(["the-history-group"])], + [ + Vdom.( + Node.div( + [Attr.classes(suc_his_classes)], + [ + history_title_entry_view( + ~is_expanded=group.is_expanded, + ~has_hidden_part=true, + group_id, + 0, /*elt_id*/ + title_entry, + ), + ], + ) + ), + ], + ) + ); + } + }; + }; + + let prev_history_view = + (history: list(UndoHistory.undo_history_group), group_id_base: int) => { + Vdom.( + Node.div( + [Attr.classes(["the-prev-history"])], + list_map_helper_func( + group_view(~is_cur_group=false), + base => base + 1, + group_id_base, + history, + ), + ) + ); + }; + let suc_history_view = + (history: list(UndoHistory.undo_history_group), group_id_base: int) => { + Vdom.( + Node.div( + [Attr.classes(["the-suc-history"])], + list_map_helper_func( + group_view(~is_cur_group=false), + base => base + 1, + group_id_base, + history, + ), + ) + ); + }; + let cur_history_view = (history: undo_history_group, group_id_base: int) => { + Vdom.( + Node.div([], [group_view(~is_cur_group=true, group_id_base, history)]) + ); + }; + let history_view = (model: Model.t) => { + let (suc_groups, cur_group, prev_groups) = model.undo_history; + let display_content = + Vdom.( + Node.div( + [Attr.classes(["the-history"])], + [ + suc_history_view(suc_groups, 0), + cur_history_view(cur_group, List.length(suc_groups)), + prev_history_view(prev_groups, List.length(suc_groups) + 1), + ], + ) + ); + let action = ZList.prj_z(cur_group.group_entries).previous_action; + switch (action) { + | None => + /*if the initial entry is the only history entry */ + if (List.length(suc_groups) <= 1) { + Vdom.( + Node.div( + [Attr.classes(["the-history"])], + [ + Vdom.( + Node.div( + [Attr.classes(["history-is-empty-msg"])], + [Node.text("no history in scope")], + ) + ), + ], + ) + ); + } else { + display_content; + } + | Some(_) => display_content + }; + }; + let undo_button = + Vdom.( + Node.div( + [ + Attr.classes(["history-button"]), + Attr.on_click(_ => inject(Update.Action.Undo)), + ], + [ + Node.div( + [Attr.classes(["undo-button-txt"])], + [Node.text("Undo")], + ), + Node.div([Attr.classes(["undo-button", "redo-undo-icon"])], []), + ], + ) + ); + + let redo_button = + Vdom.( + Node.div( + [ + Attr.classes(["history-button"]), + Attr.on_click(_ => inject(Update.Action.Redo)), + ], + [ + Node.div([Attr.classes(["redo-button", "redo-undo-icon"])], []), + Node.div( + [Attr.classes(["redo-button-txt"])], + [Node.text("Redo")], + ), + ], + ) + ); + + let expand_button = (all_hidden_history_expand: bool) => { + let icon_classes = + if (all_hidden_history_expand) { + ["all-history-tab-icon-open", "history-tab-icon"]; + } else { + ["all-history-tab-icon-close", "history-tab-icon"]; + }; + Vdom.( + Node.div( + [ + Attr.classes(icon_classes), + Attr.on_click(_ => inject(Update.Action.ToggleHiddenHistoryAll)), + ], + [], + ) + ); + }; + + let button_bar_view = (all_hidden_history_expand: bool) => + Vdom.( + Node.div( + [Attr.classes(["history_button_bar"])], + [undo_button, redo_button, expand_button(all_hidden_history_expand)], + ) + ); + + Vdom.( + Node.div( + [Attr.classes(["panel", "context-inspector-panel"])], + [ + Panel.view_of_main_title_bar("history"), + button_bar_view(model.all_hidden_history_expand), + Node.div( + [Attr.classes(["panel-body", "context-inspector-body"])], + [history_view(model)], + ), + ], + ) + ); +}; diff --git a/src/hazelweb/model/Model.re b/src/hazelweb/model/Model.re index 50266e096c..ed587c4cda 100644 --- a/src/hazelweb/model/Model.re +++ b/src/hazelweb/model/Model.re @@ -8,6 +8,7 @@ type t = { right_sidebar_open: bool, show_contenteditable: bool, show_presentation: bool, + all_hidden_history_expand: bool, undo_history: UndoHistory.t, }; @@ -21,9 +22,21 @@ let cardstack_info = [ let init = (): t => { let cardstacks = Cardstacks.mk(cardstack_info); let undo_history = { - let edit_state = - cardstacks |> Cardstacks.get_program |> Program.get_edit_state; - ([], edit_state, []); + let (cur_cursor_term, prev_is_empty_line) = + UndoHistory.get_cursor_info(cardstacks); + let undo_history_entry: UndoHistory.undo_history_entry = { + cardstacks, + previous_action: None, + previous_cursor_term: None, + current_cursor_term: cur_cursor_term, + prev_is_empty_line, + }; + let undo_history_group: UndoHistory.undo_history_group = { + group_entries: ([], undo_history_entry, []), + is_expanded: false, + is_complete: true, + }; + ([], undo_history_group, []); }; { cardstacks, @@ -35,6 +48,7 @@ let init = (): t => { right_sidebar_open: true, show_contenteditable: false, show_presentation: false, + all_hidden_history_expand: false, }; }; @@ -86,14 +100,15 @@ let perform_edit_action = (a: Action.t, model: t): t => { |> put_undo_history( { let history = model |> get_undo_history; - if (UndoHistory.undoable_action(a)) { - UndoHistory.push_edit_state( - history, - Program.get_edit_state(new_program), - ); - } else { - history; - }; + let cardstacks = model |> get_cardstacks; + let new_cardstacks = + model |> put_program(new_program) |> get_cardstacks; + UndoHistory.push_edit_state( + history, + cardstacks, + new_cardstacks, + Some(a), + ); }, ); }; @@ -127,3 +142,73 @@ let load_example = (model: t, e: UHExp.t): t => let load_cardstack = (model, idx) => { model |> map_cardstacks(Cardstacks.load_cardstack(idx)) |> focus_cell; }; +let undo = (model: t): t => { + let new_history = { + let cur_group = ZList.prj_z(model.undo_history); + /* shift to previous state in the same group */ + switch (ZList.shift_next(cur_group.group_entries)) { + | None => + /*if current group doesn't have previous state, shfit to previous group*/ + switch (ZList.shift_next(model.undo_history)) { + | None => model.undo_history + | Some(new_history) => + let new_group = ZList.prj_z(new_history); + let new_group': UndoHistory.undo_history_group = { + group_entries: ZList.shift_begin(new_group.group_entries), /*pointer may be in the wrong position after clicking an arbitrary entry in the history panel*/ + is_expanded: true, + is_complete: new_group.is_complete, + }; /* is_expanded=true because the selected group should be expanded*/ + ZList.replace_z(new_group', new_history); + } + | Some(new_group_entries) => + let new_group: UndoHistory.undo_history_group = { + group_entries: new_group_entries, + is_expanded: true, + is_complete: cur_group.is_complete, + }; + ZList.replace_z(new_group, model.undo_history); /* is_expanded=true because the selected group should be expanded*/ + }; + }; + let cur_group' = ZList.prj_z(new_history); + let new_cardstacks = ZList.prj_z(cur_group'.group_entries).cardstacks; + + //let new_model = model |> Model.put_program(Program.mk(new_edit_state)); + + //let model' = update_cardstacks_state(model, new_cardstacks_state); + let model' = model |> put_cardstacks(new_cardstacks); + {...model', undo_history: new_history}; +}; + +let redo = (model: t): t => { + let new_history = { + let cur_group = ZList.prj_z(model.undo_history); + /* shift to previous state in the same group */ + switch (ZList.shift_prev(cur_group.group_entries)) { + | None => + /*if current group doesn't have previous state, shfit to previous group*/ + switch (ZList.shift_prev(model.undo_history)) { + | None => model.undo_history + | Some(new_history) => + let new_group = ZList.prj_z(new_history); + let new_group': UndoHistory.undo_history_group = { + group_entries: ZList.shift_end(new_group.group_entries), /*pointer may be in the wrong position after clicking an arbitrary entry in the history panel*/ + is_expanded: true, + is_complete: new_group.is_complete, + }; /* is_expanded=true because this group should be expanded when redo*/ + ZList.replace_z(new_group', new_history); + } + | Some(new_group_entries) => + let new_group: UndoHistory.undo_history_group = { + group_entries: new_group_entries, + is_expanded: true, + is_complete: cur_group.is_complete, + }; + ZList.replace_z(new_group, model.undo_history); /* is_expanded=true because the selected group should be expanded*/ + }; + }; + let cur_group' = ZList.prj_z(new_history); + let new_cardstacks = ZList.prj_z(cur_group'.group_entries).cardstacks; + //let model' = update_cardstacks_state(model, new_cardstacks_state); + let model' = model |> put_cardstacks(new_cardstacks); + {...model', undo_history: new_history}; +}; diff --git a/src/hazelweb/model/UndoHistory.re b/src/hazelweb/model/UndoHistory.re index 1c96abd556..40cc0df27e 100644 --- a/src/hazelweb/model/UndoHistory.re +++ b/src/hazelweb/model/UndoHistory.re @@ -1,43 +1,164 @@ -type t = ZList.t(Statics.edit_state, Statics.edit_state); +type cursor_term = CursorInfo.cursor_term; +type undo_history_entry = { + cardstacks: Cardstacks.t, + previous_action: option(Action.t), + previous_cursor_term: option(cursor_term), + current_cursor_term: option(cursor_term), + prev_is_empty_line: bool, +}; -let push_edit_state = (undo_history: t, edit_state: Statics.edit_state): t => { - /* first add new edit state to the end, then shift_next */ - let after_push = ( - ZList.prj_prefix(undo_history), - ZList.prj_z(undo_history), - [edit_state], - ); - switch (ZList.shift_next(after_push)) { - | None => failwith("Impossible because suffix is non-empty") - | Some(new_history) => new_history +type undo_history_group = { + group_entries: ZList.t(undo_history_entry, undo_history_entry), + is_expanded: bool, + /* [is_complete: bool] if any cursor-moving action interupts the current edit, + the current group becomes complete. + Next action will start a new group */ + is_complete: bool, +}; + +type t = ZList.t(undo_history_group, undo_history_group); + +let get_cursor_info = + (cardstacks: Cardstacks.t): (option(cursor_term), bool) => { + let zexp = + ZList.prj_z(ZList.prj_z(cardstacks).zcards).program |> Program.get_zexp; + CursorInfo.extract_cursor_term(zexp); +}; + +let undoable_action = (action: option(Action.t)): bool => { + switch (action) { + | None => + failwith( + "Impossible match. None of None-action will be pushed into history", + ) + | Some(action') => + switch (action') { + | UpdateApPalette(_) => + failwith("ApPalette is not implemented in undo_history") + | Delete + | Backspace + | Construct(_) => true + | MoveTo(_) + | MoveToBefore(_) + | MoveLeft + | MoveRight + | MoveToNextHole + | MoveToPrevHole => false + } }; }; -let undo = (undo_history: t): t => { - switch (ZList.shift_prev(undo_history)) { - | None => undo_history - | Some(new_history) => new_history +let in_same_history_group = + (~prev_entry: undo_history_entry, ~cur_entry: undo_history_entry): bool => { + switch (prev_entry.previous_action, cur_entry.previous_action) { + | (None, _) + | (_, None) => false + | (Some(detail_action_1), Some(detail_action_2)) => + switch (detail_action_1, detail_action_2) { + | (Delete, Delete) + | (Backspace, Backspace) => + CursorInfo.can_group_cursor_term( + prev_entry.current_cursor_term, + cur_entry.current_cursor_term, + ) + | (Construct(shape_1), Construct(shape_2)) => + /* if shapes are similar, then continue to check if they have similar cursor_term */ + if (Action.can_group_shape(shape_1, shape_2)) { + CursorInfo.can_group_cursor_term( + prev_entry.current_cursor_term, + cur_entry.current_cursor_term, + ); + } else { + false; + } + | (UpdateApPalette(_), _) => + failwith("ApPalette is not implemented in undo_history") + | (Delete, _) + | (Backspace, _) + | (Construct(_), _) => false + | (MoveTo(_), _) + | (MoveToBefore(_), _) + | (MoveLeft, _) + | (MoveRight, _) + | (MoveToNextHole, _) + | (MoveToPrevHole, _) => + failwith( + "Impossible match. Not undoable actions will not be added into history", + ) + } }; }; -let redo = (undo_history: t): t => { - switch (ZList.shift_next(undo_history)) { - | None => undo_history - | Some(new_history) => new_history +let push_edit_state = + ( + undo_history: t, + prev_cardstacks: Cardstacks.t, + cur_cardstacks: Cardstacks.t, + action: option(Action.t), + ) + : t => { + let prev_group = ZList.prj_z(undo_history); + let prev_entry = ZList.prj_z(prev_group.group_entries); + if (undoable_action(action)) { + let (prev_cursor_term, _) = get_cursor_info(prev_cardstacks); + let (cur_cursor_term, prev_is_empty_line) = + get_cursor_info(cur_cardstacks); + let cur_entry = { + cardstacks: cur_cardstacks, + previous_action: action, + previous_cursor_term: prev_cursor_term, + current_cursor_term: cur_cursor_term, + prev_is_empty_line, + }; + if (!prev_group.is_complete + && in_same_history_group(~prev_entry, ~cur_entry)) { + /* group the new entry into the current group */ + let group_entries_after_push = ( + [], + cur_entry, + [ + ZList.prj_z(prev_group.group_entries), + ...ZList.prj_suffix(prev_group.group_entries), + ], + ); + ( + [], + { + group_entries: group_entries_after_push, + is_expanded: false, + is_complete: false, + }, /* initial expanded-state of a group should be folded*/ + ZList.prj_suffix(undo_history), + ); + } else { + /* start a new group */ + let new_group = { + group_entries: ([], cur_entry, []), + is_expanded: false, + is_complete: false, + }; + ( + [], + new_group, + [ZList.prj_z(undo_history), ...ZList.prj_suffix(undo_history)], + ); + }; + } else { + /* if any cursor-moving action interupts the current edit, + the current group becomes complete. */ + let prev_group' = {...prev_group, is_complete: true}; + ZList.replace_z(prev_group', undo_history); }; }; -let undoable_action = (action: Action.t): bool => { - switch (action) { - | UpdateApPalette(_) - | Delete - | Backspace - | Construct(_) => true - | MoveTo(_) - | MoveToBefore(_) - | MoveLeft - | MoveRight - | MoveToNextHole - | MoveToPrevHole => false +let set_all_hidden_history = (undo_history: t, expanded: bool): t => { + let hidden_group = (group: undo_history_group) => { + ...group, + is_expanded: expanded, }; + ( + List.map(hidden_group, ZList.prj_prefix(undo_history)), + hidden_group(ZList.prj_z(undo_history)), + List.map(hidden_group, ZList.prj_suffix(undo_history)), + ); }; diff --git a/src/hazelweb/www/style.css b/src/hazelweb/www/style.css index d0b0bec492..03226463d4 100644 --- a/src/hazelweb/www/style.css +++ b/src/hazelweb/www/style.css @@ -517,6 +517,13 @@ html, body { border-right: 0px; } +.history-entry { + font-size: 125%; + border: 1px outset #ffffff; + border-left: 0px; + border-right: 0px; +} + .instructional-msg { background-color: var(--title-bar-color); padding: 5px; @@ -1338,3 +1345,131 @@ h1 { flex-direction: column; align-content: flex-start; } + +/* edit action history panel */ + +.history-is-empty-msg { + margin-top: 10px; + opacity: 0.50; + text-align: center; + /* text-transform: uppercase; */ + font-size: 75%; +} +.the-hidden-history-entry { + cursor: pointer; + padding: 5px 5px 5px 20px; + font-size: 12pt; + width: 100%; + border: 1px outset #ffffff; +} +.the-hidden-history-entry:hover { + color: #b30000; + background-color: lightgoldenrodyellow; +} +.the-history-title { + display: inline-block; + padding: 5px; +} +.the-history-title:hover { + color: #b30000; + background-color: lightgoldenrodyellow; +} +.the-history-title-entry { + float: left; + width: 100%; +} +.the-history-title-txt { + cursor: pointer; + float: left; +} +.the-prev-history { + color: #0d0a05; + background-color: #f0fff3; +} + +.the-suc-history { + color: dimgray; + background-color: lightgray; +} +.the-cur-history { + color: #b30000; + overflow-anchor: auto; + background-color: lightgoldenrodyellow; +} + + +.always-display-history-entry { + border: 1px outset #ffffff; + width: 100%; + display: grid; +} +.history-tab-icon { + cursor: pointer; + float: right; + width: 0; + height: 0; +} +.down-triangle { + border-left: 8px solid transparent; + border-right: 8px solid transparent; + border-top: 10px solid #558e62; +} + +.left-triangle { + border-bottom: 8px solid transparent; + border-top: 8px solid transparent; + border-right: 10px solid #558e62; +} + +.all-history-tab-icon-open { + border-left: 8px solid transparent; + border-right: 8px solid transparent; + border-top: 10px solid white; +} + +.all-history-tab-icon-close, .undo-button { +border-bottom: 8px solid transparent; +border-top: 8px solid transparent; +border-right: 10px solid white; +} +.redo-button { + border-bottom: 8px solid transparent; + border-top: 8px solid transparent; + border-left: 10px solid white; +} +.redo-undo-icon { + display: table-cell; + margin-left: 10px; + margin-right: 10px; +} + + +.history_button_bar { + text-transform: uppercase; + color: white; + padding: 3px 5px 3px 3px; + font-size: 10pt; + background-color: #678a61; + display: table; +} +.history-button { + cursor: pointer; + margin-right: 5px; + display: inline-table; +} +.undo-button-txt { + + display: table-cell; + padding-right: 15px; + vertical-align: center; +} + +.redo-button-txt { + + display: table-cell; + padding-left: 15px; + vertical-align: center; + } + + +