From 29f57d74aa2a0a12a25ed13a76d57da05162c90c Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Tue, 19 May 2026 17:18:17 +0100 Subject: [PATCH 1/5] fn/rewrite includes cut --- docs/TODO.md | 24 ++++++---- fn/rewrite/amb.fn | 14 +++++- fn/rewrite/annotate.fn | 4 ++ fn/rewrite/beta_reduce.fn | 4 ++ fn/rewrite/constant_folding.fn | 5 ++ fn/rewrite/cps.fn | 8 ++++ fn/rewrite/desugar.fn | 4 ++ fn/rewrite/eta_reduce.fn | 4 ++ fn/rewrite/expr.fn | 8 ++++ fn/rewrite/fold_iff.fn | 84 ++++++++++++++++++++++++++++++++++ fn/rewrite/minexpr.fn | 9 ++++ fn/rewrite/samples.fn | 3 ++ fn/rewrite/subst.fn | 4 ++ fn/rewrite/test_harness.fn | 5 +- fn/rewrite/transform.fn | 4 ++ fn/rewrite/unconvert.fn | 4 ++ 16 files changed, 175 insertions(+), 13 deletions(-) create mode 100644 fn/rewrite/fold_iff.fn diff --git a/docs/TODO.md b/docs/TODO.md index c15bf383..5ff171d0 100644 --- a/docs/TODO.md +++ b/docs/TODO.md @@ -4,29 +4,33 @@ More of a wish-list than a hard and fast plan. * More folding opportunities. * fold boolean expressions `true and false => false`. - * fold boolean comparisons `a == a => true`, `a >= a => true` etc. - * fold constant conditions `(if true a b) => a`. + * tricky because `and`, `or` etc. are not primitive, they are lazy operators defined in terms of `if` in the preamble. + * fold boolean comparisons `a == a => true`, `a >= a => true` etc. DONE + * fold constant conditions `(if true a b) => a`. DONE + * This solves the boolean expression folding problem, after β/η-reduction: + * `true and false => (if true false false) => false` + * fold duplicate condition branches `(if x a a) => a`. * Continuations. - * Reinstate `cut` (prunes current back continuation). - * all back continuations would take a boolean `skip` argument. - * `cut` would install a new back continuation that calls its parent with `skip` true. + * Reinstate `cut` (prunes current back continuation). DONE * Implement delimited continuations. * Types. * Consider type classes as a general solution to `EQ `, `map` etc. * Records should create accessor functions for each tag. * if there is only one type variant. + * extend the `typedef` keyword. + * `typedef container(#t);` is shorthand for `typedef container(#t) { container(#t) };` + * `typedef container(char);` is shorthand for `typedef container { container(char) };` + * no additional AST should be required, or if it is it gets immediately desugared so doesn't leak downstream. * Namespaces. - * We want `import function ` and `import functions`. + * We want `import function ` and `import functions`. DONE mostly. * And `import typedef ` and `import typedefs`. * Parser. - * re-elist the now-available `macro` keyword for proper syntactic extensibility: + * re-elist the now-available `macro` keyword for proper syntactic extensibility. DONE * if/then/else => `(fn { (true) {then} (false) {else} }(if))` (we already do this but hard-coded in the parser). * `do` notation for monads. * Memory Management. * Replace mark and sweep GC with a generational stop and copy. * Pipeline. - * Extend operator folding to include boolean operators. - * Fold conditionals that have constant tests. * Re-order Type Checking before TPMC. * Target LLVM. * Generate. @@ -57,3 +61,5 @@ More of a wish-list than a hard and fast plan. * Make i/o pleasant to use. * Any ideas welcome, currently it's a mess. * Specifically think about ways to support parsing. + * Generated printers should take a file handle, wrapper printer supplies stdout. + * Generate parsers alongside printers. diff --git a/fn/rewrite/amb.fn b/fn/rewrite/amb.fn index d14d5437..c03bd004 100644 --- a/fn/rewrite/amb.fn +++ b/fn/rewrite/amb.fn @@ -14,11 +14,21 @@ fn amb(e, f) { switch (e) { (M.amb_expr(a, b)) { - amb(a, M.lambda([], amb(b, f))) + // amb(a, M.lambda([], amb(b, f))) + amb(a, + M.lambda(["skip"], + M.if_expr(M.var("skip"), + M.apply(f, [M.stdint(0)]), + amb(b, f)))) + } + + (M.cut_expr(e)) { + amb(e, M.lambda(["skip"], + M.apply(f, [M.stdint(1)]))) } (M.back_expr) { - M.apply(f, []) + M.apply(f, [M.stdint(0)]) } (M.apply(x=M.primop(_), args)) { diff --git a/fn/rewrite/annotate.fn b/fn/rewrite/annotate.fn index af5eba4f..0acff42c 100644 --- a/fn/rewrite/annotate.fn +++ b/fn/rewrite/annotate.fn @@ -38,6 +38,10 @@ fn annotate(expr) { M.callcc_expr(ann(e)) } + (M.cut_expr(e)) { + M.cut_expr(ann(e)) + } + (M.cond_expr(test, branches)) { M.cond_expr(ann(test), branches |> ann && ann) } diff --git a/fn/rewrite/beta_reduce.fn b/fn/rewrite/beta_reduce.fn index 9b3ec819..bd36d826 100644 --- a/fn/rewrite/beta_reduce.fn +++ b/fn/rewrite/beta_reduce.fn @@ -44,6 +44,10 @@ fn reduce { M.callcc_expr(reduce(e)) } + (M.cut_expr(e)) { + M.cut_expr(reduce(e)) + } + (M.cond_expr(test, branches)) { M.cond_expr(reduce(test), branches |> reduce && reduce) } diff --git a/fn/rewrite/constant_folding.fn b/fn/rewrite/constant_folding.fn index 6e59b57a..9a063d20 100644 --- a/fn/rewrite/constant_folding.fn +++ b/fn/rewrite/constant_folding.fn @@ -242,6 +242,11 @@ fn fold { M.callcc_expr(fold(e)) } + (M.cut_expr(e)) { + // cut_expr(expr) + M.cut_expr(fold(e)) + } + (M.cond_expr(test, branches)) { // cond_expr(expr, list(#(expr, expr))) M.cond_expr(fold(test), branches |> fold && fold) diff --git a/fn/rewrite/cps.fn b/fn/rewrite/cps.fn index 4b1319ea..eaabd2ff 100644 --- a/fn/rewrite/cps.fn +++ b/fn/rewrite/cps.fn @@ -58,6 +58,10 @@ namespace T_c(M.callcc_expr(e), c) } + (M.cut_expr(e)) { + M.cut_expr(T_c(e, kToC(k))) + } + (M.cond_expr(test, branches)) { let c = kToC(k); @@ -154,6 +158,10 @@ namespace }) } + (M.cut_expr(e)) { + M.cut_expr(T_c(e, c)) + } + (M.cond_expr(test, branches)) { let sk = GS.genstring("$k"); diff --git a/fn/rewrite/desugar.fn b/fn/rewrite/desugar.fn index d81e7de2..6adf95e7 100644 --- a/fn/rewrite/desugar.fn +++ b/fn/rewrite/desugar.fn @@ -56,6 +56,10 @@ namespace M.callcc_expr(desugar(e)) } + (E.cut_expr(e)) { + M.cut_expr(desugar(e)) + } + (E.cond_expr(test, branches)) { M.cond_expr(desugar(test), branches |> desugar && desugar); } diff --git a/fn/rewrite/eta_reduce.fn b/fn/rewrite/eta_reduce.fn index 66e9db37..7ac96ac6 100644 --- a/fn/rewrite/eta_reduce.fn +++ b/fn/rewrite/eta_reduce.fn @@ -42,6 +42,10 @@ fn reduce { M.callcc_expr(reduce(e)) } + (M.cut_expr(e)) { + M.cut_expr(reduce(e)) + } + (M.cond_expr(test, branches)) { M.cond_expr(reduce(test), branches |> reduce && reduce) } diff --git a/fn/rewrite/expr.fn b/fn/rewrite/expr.fn index ba5e871a..b40b5a56 100644 --- a/fn/rewrite/expr.fn +++ b/fn/rewrite/expr.fn @@ -13,6 +13,7 @@ namespace constant(string, number) | constructor_info(string) | construct(string, number, list(expr)) | + cut_expr(expr) | deconstruct(string, number, expr) | env_expr | error_expr | @@ -81,6 +82,12 @@ namespace puts(")"); x; } + (x=cut_expr(e)) { + puts("(cut "); + print_expr(e); + puts(")"); + x; + } (x=typeof_expr(e)) { puts("(typeof "); print_expr(e); @@ -360,6 +367,7 @@ namespace (atom(s)) { var(s) } (sexp([atom("amb"), a, b])) { amb_expr(to_expr(a), to_expr(b)) } (sexp([atom("call/cc"), e])) { callcc_expr(to_expr(e)) } + (sexp([atom("cut"), e])) { cut_expr(to_expr(e)) } (sexp([atom("if"), e1, e2, e3])) { if_expr(to_expr(e1), to_expr(e2), to_expr(e3)) } (sexp(atom("cond") @ test @ branches)) { cond_expr(to_expr(test), branches |> fn { (sexp([e1, e2])) { #(to_expr(e1), to_expr(e2)) } diff --git a/fn/rewrite/fold_iff.fn b/fn/rewrite/fold_iff.fn new file mode 100644 index 00000000..30b85f72 --- /dev/null +++ b/fn/rewrite/fold_iff.fn @@ -0,0 +1,84 @@ +namespace + +// (if true a b) => a + +link "minexpr.fn" as M; +link "env.fn" as Env; +link "subst.fn" as SUBST; +link "occurs_in.fn" as O; +link "../listutils.fn" as list; +link "../dictutils.fn" as DICT; +import list operator "_|>_"; +import list operator "_&&_"; +import list operator "_any_"; + +fn fold { + (M.amb_expr(expr1, expr2)) { + M.amb_expr(fold(expr1), fold(expr2)) + } + + (M.apply(fun, args)) { + M.apply(fold(fun), args |> fold) + } + + (x = M.back_expr) | + (x = M.primop(_)) | + (x = M.bigint(_)) | + (x = M.character(_)) | + (x = M.var(_)) | + (x = M.stdint(_)) { + x + } + + (M.callcc_expr(e)) { + M.callcc_expr(fold(e)) + } + + (M.cut_expr(e)) { + M.cut_expr(fold(e)) + } + + (M.cond_expr(test, branches)) { + M.cond_expr(fold(test), branches |> fold && fold) + } + + (M.if_expr(exprc, exprt, exprf)) { + switch (fold(exprc)) { + (c = M.stdint(1)) { + fold(exprt) + } + (c = M.stdint(0)) { + fold(exprf) + } + (c) { + M.if_expr(c, fold(exprt), fold(exprf)) + } + } + } + + (M.lambda(params, body)) { + M.lambda(params, fold(body)) + } + + (M.letrec_expr(bindings, expr)) { + M.letrec_expr(bindings |> identity && (fold && identity), fold(expr)) + } + + (M.make_vec(size, args)) { + M.make_vec(size, args |> fold) + } + + (M.match_cases(test, cases)) { + M.match_cases(fold(test), cases |> identity && fold) + } + + (M.sequence(exprs)) { + M.sequence(exprs |> fold) + } + + (x) { + M.print_expr(x); + puts("\n"); + error("fold_iff: unsupported expression") + } +} \ No newline at end of file diff --git a/fn/rewrite/minexpr.fn b/fn/rewrite/minexpr.fn index eeeb3f3c..4e32d0c1 100644 --- a/fn/rewrite/minexpr.fn +++ b/fn/rewrite/minexpr.fn @@ -12,6 +12,7 @@ namespace callcc_expr(expr) | character(char) | cond_expr(expr, list(#(expr, expr))) | + cut_expr(expr) | done_expr | env_ref(expr, number) | if_expr(expr, expr, expr) | @@ -185,6 +186,13 @@ namespace puts(")"); x; } + (cut_expr(e)) { + puts("(cut"); + put_indent(depth + 1); + go(depth + 1, e); + puts(")"); + x; + } (stdint(i)) { putn(i); x; @@ -379,6 +387,7 @@ namespace (sexp([atom("done")])) { done_expr } (sexp([atom("amb"), a, b])) { amb_expr(to_expr(a), to_expr(b)) } (sexp([atom("call/cc"), e])) { callcc_expr(to_expr(e)) } + (sexp([atom("cut"), e])) { cut_expr(to_expr(e)) } (sexp([atom("if"), e1, e2, e3])) { if_expr(to_expr(e1), to_expr(e2), to_expr(e3)) } (sexp(atom("cond") @ test @ branches)) { cond_expr(to_expr(test), branches |> fn { (sexp([e1, e2])) { #(to_expr(e1), to_expr(e2)) } diff --git a/fn/rewrite/samples.fn b/fn/rewrite/samples.fn index 405dfda2..9e3ead19 100644 --- a/fn/rewrite/samples.fn +++ b/fn/rewrite/samples.fn @@ -391,4 +391,7 @@ namespace "(+ (/ x 2) (/ y 2))", "(- (/ x 2) (/ y 2))", "(/ (* k x) (* k y))", + + ";97. cut ---", + "(amb (amb (cut 1) 2) 3)", ]}; diff --git a/fn/rewrite/subst.fn b/fn/rewrite/subst.fn index 7b4c897d..f509df1f 100644 --- a/fn/rewrite/subst.fn +++ b/fn/rewrite/subst.fn @@ -39,6 +39,10 @@ namespace M.callcc_expr(substitute(c, e)) } + (M.cut_expr(e)) { + M.cut_expr(substitute(c, e)) + } + // cond_expr(expr, list(#(expr, expr))) (M.cond_expr(test, branches)) { M.cond_expr(substitute(c, test), diff --git a/fn/rewrite/test_harness.fn b/fn/rewrite/test_harness.fn index f0c46dc7..c049f00b 100644 --- a/fn/rewrite/test_harness.fn +++ b/fn/rewrite/test_harness.fn @@ -16,6 +16,7 @@ let link "unconvert.fn" as UCV; link "annotate.fn" as AN; link "amb.fn" as AMB; + link "fold_iff.fn" as IFF; in list.for_each(fn { (';' @ s) { @@ -27,7 +28,6 @@ in (str) { let halt = M.var("□"); - // halt = M.parse("(lambda (f) (done))") fail = M.var("Ω"); a = E.parse(str); b = DS.desugar(a); @@ -40,7 +40,8 @@ in g = OF.fold(f); gg = AMB.amb(g, fail); ggg = β.reduce(gg); - h = CC.shared_closure_convert(ggg); + gggg = IFF.fold(ggg); + h = CC.shared_closure_convert(gggg); hh = UCV.unconvert(h); hhh = AN.annotate(hh); nltab = "\n"; diff --git a/fn/rewrite/transform.fn b/fn/rewrite/transform.fn index 55159cfd..767c573e 100644 --- a/fn/rewrite/transform.fn +++ b/fn/rewrite/transform.fn @@ -43,6 +43,10 @@ fn _transform(t, a, exp) { M.callcc_expr(t(a, e)) } + (M.cut_expr(e)) { + M.cut_expr(t(a, e)) + } + (M.cond_expr(test, branches)) { M.cond_expr(t(a, test), branches |> t(a) && t(a)) } diff --git a/fn/rewrite/unconvert.fn b/fn/rewrite/unconvert.fn index 478310e8..d2b54d6b 100644 --- a/fn/rewrite/unconvert.fn +++ b/fn/rewrite/unconvert.fn @@ -39,6 +39,10 @@ fn unconvert { M.callcc_expr(unconvert(e)) } + (M.cut_expr(e)) { + M.cut_expr(unconvert(e)) + } + (M.cond_expr(test, branches)) { M.cond_expr(unconvert(test), branches |> unconvert && unconvert) } From 176c690a9ad6b2a2c13cb3bc967b8aad93de37f0 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Tue, 19 May 2026 17:30:57 +0100 Subject: [PATCH 2/5] tests and doc example --- docs/CUT.md | 19 +++++++++++++++ tests/fn/fail_cut_no_choice.fn | 7 ++++++ tests/fn/test_cut.fn | 44 ++++++++++++++++++++++++++++++++++ 3 files changed, 70 insertions(+) create mode 100644 tests/fn/fail_cut_no_choice.fn create mode 100644 tests/fn/test_cut.fn diff --git a/docs/CUT.md b/docs/CUT.md index ad33b4e2..8928a49f 100644 --- a/docs/CUT.md +++ b/docs/CUT.md @@ -231,3 +231,22 @@ intended run-time error. 2. Nested `amb` and `cut`. 3. `cut` with no enclosing choice point. 4. Interaction with `here` and escaped continuations. + +### Examples + +```shell +$ ./bin/fn --exec='print (1 then 2) then 3; back' +1 +2 +3 + +$ ./bin/fn --exec='print ((cut 1) then 2) then 3; back' +1 +3 + +$ ./bin/fn --exec='print (cut 1 then 2) then 3; back' +1 +2 + +$ +``` diff --git a/tests/fn/fail_cut_no_choice.fn b/tests/fn/fail_cut_no_choice.fn new file mode 100644 index 00000000..b7433307 --- /dev/null +++ b/tests/fn/fail_cut_no_choice.fn @@ -0,0 +1,7 @@ +// test files starting with 'fail_' are expected to fail +// cut without an enclosing choice point should raise a runtime error + +let + result = cut 1; +in + assert(result == 1) \ No newline at end of file diff --git a/tests/fn/test_cut.fn b/tests/fn/test_cut.fn new file mode 100644 index 00000000..8de51d66 --- /dev/null +++ b/tests/fn/test_cut.fn @@ -0,0 +1,44 @@ +// Test cut control effects and parsing precedence + +let + fn test_cut_returns_value() { + let + result = (cut 1) then 2; + in + assert(result == 1); + } + + fn test_cut_commits_current_branch() { + let + result = { + let chosen = ((cut 1) then 2) then 3; + in if (chosen == 1) { back } else { chosen } + }; + in + assert(result == 3); + } + + fn test_cut_wraps_whole_choice() { + let + result = { + let chosen = (cut 1 then 2) then 3; + in if (chosen == 1) { back } else { chosen } + }; + in + assert(result == 2); + } + + fn test_cut_through_here() { + let + result = { + let chosen = here fn (k) { k((cut 1) then 2) then 3 }; + in if (chosen == 1) { back } else { chosen } + }; + in + assert(result == 3); + } +in + test_cut_returns_value(); + test_cut_commits_current_branch(); + test_cut_wraps_whole_choice(); + test_cut_through_here() \ No newline at end of file From e2b55a954515a90ccee49db0f1926109de1e4250 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Tue, 19 May 2026 18:12:47 +0100 Subject: [PATCH 3/5] added tests, tripped and fixed 2 bugs --- fn/parseramb.fn | 47 +++++++++++++++++ src/minlam_cfo.c | 5 ++ src/minlam_subst.c | 9 ++++ tests/fn/test_parseramb.fn | 100 ++++++++++++++++++++++++++++++++++++- 4 files changed, 160 insertions(+), 1 deletion(-) diff --git a/fn/parseramb.fn b/fn/parseramb.fn index d5696be0..c7584836 100644 --- a/fn/parseramb.fn +++ b/fn/parseramb.fn @@ -93,6 +93,20 @@ fn optional(parser) { ]) } +// Commits to the present branch after a successful parse. +// This is useful when downstream backtracking should not reinterpret +// a present token as absent. +fn optional_commit(parser) { + choice_first([ + fn (input) { + bind_state(parser, fn (value, rest) { + cut (pure(just(value))(rest)) + }, input) + }, + pure(nothing) + ]) +} + fn many(parser) { choice_first([ fn (input) { @@ -110,6 +124,25 @@ fn many(parser) { ]) } +// Greedy repetition: once a consuming iteration succeeds, do not +// backtrack to a shorter split at this repetition node. +fn many_commit(parser) { + choice_first([ + fn (input) { + bind_state(parser, fn (head, rest1) { + if (rest1 != input) { + cut (bind_state(many_commit(parser), fn (tail, rest2) { + pure([head] @@ tail)(rest2) + }, rest1)) + } else { + back + } + }, input) + }, + pure([]) + ]) +} + fn some(parser) { fn (input) { bind_state(parser, fn (head, rest1) { @@ -124,6 +157,20 @@ fn some(parser) { } } +fn some_commit(parser) { + fn (input) { + bind_state(parser, fn (head, rest1) { + if (rest1 != input) { + cut (bind_state(many_commit(parser), fn (tail, rest2) { + pure([head] @@ tail)(rest2) + }, rest1)) + } else { + back + } + }, input) + } +} + fn chainl1(parser, operatorParser) { let fn step(input) { bind_state(operatorParser, fn (opFn, rest1) { diff --git a/src/minlam_cfo.c b/src/minlam_cfo.c index bbe52437..669cd465 100644 --- a/src/minlam_cfo.c +++ b/src/minlam_cfo.c @@ -269,6 +269,11 @@ static void cfoMinExp(MinExp *node, VisitorContext context) { cfoMinCond(variant, context); break; } + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + cfoMinExp(variant, context); + break; + } case MINEXP_TYPE_DONE: { // int break; diff --git a/src/minlam_subst.c b/src/minlam_subst.c index 00fd5488..aebd0d50 100644 --- a/src/minlam_subst.c +++ b/src/minlam_subst.c @@ -635,6 +635,15 @@ MinExp *substMinExp(MinExp *node, MinExpTable *context) { } break; } + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = substMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_IFF: { // MinIff MinIff *variant = getMinExp_Iff(node); diff --git a/tests/fn/test_parseramb.fn b/tests/fn/test_parseramb.fn index cc09f81f..46d1b78b 100644 --- a/tests/fn/test_parseramb.fn +++ b/tests/fn/test_parseramb.fn @@ -5,10 +5,18 @@ let import parser.bind; import parser.chainl1; import parser.choice_first; + import parser.literal; import parser.map; + import parser.many; + import parser.many_commit; + import parser.optional; + import parser.optional_commit; import parser.parse_complete; + import parser.parse_with_meaning; import parser.pure; import parser.satisfy; + import parser.some; + import parser.some_commit; import parserdo macro pdo; fn toNum(str) { @@ -38,9 +46,99 @@ in { from parse_number as rhs; yield #(lhs, rhs) ]; + parse_optional = optional(literal(["a"])); + parse_optional_commit = optional_commit(literal(["a"])); + parse_many = many(literal(["a"])); + parse_many_commit = many_commit(literal(["a"])); + parse_some = some(literal(["a"])); + parse_some_commit = some_commit(literal(["a"])); + parse_optional_overlap = pdo[ + from optional(literal(["a"])) as prefix; + from literal(["a"]) as noun; + yield #(prefix, noun) + ]; + parse_optional_overlap_commit = pdo[ + from optional_commit(literal(["a"])) as prefix; + from literal(["a"]) as noun; + yield #(prefix, noun) + ]; + parse_many_overlap = pdo[ + from many(literal(["a"])) as prefixes; + from literal(["a"]) as noun; + yield #(prefixes, noun) + ]; + parse_many_overlap_commit = pdo[ + from many_commit(literal(["a"])) as prefixes; + from literal(["a"]) as noun; + yield #(prefixes, noun) + ]; + parse_some_overlap = pdo[ + from some(literal(["a"])) as prefixes; + from literal(["a"]) as noun; + yield #(prefixes, noun) + ]; + parse_some_overlap_commit = pdo[ + from some_commit(literal(["a"])) as prefixes; + from literal(["a"]) as noun; + yield #(prefixes, noun) + ]; in { assert(parse_complete(parse_sum, ["12", "+", "34", "+", "56"]) == 102); assert(parse_complete(parse_sum, ["20", "-", "3", "-", "4"]) == 13); - assert(parse_complete(parse_pair, ["7", "8"]) == #(7, 8)) + assert(parse_complete(parse_pair, ["7", "8"]) == #(7, 8)); + + assert(parse_with_meaning(parse_optional, fn (result) { result == nothing }, ["a"]) == nothing); + assert( + ({ + parse_with_meaning(parse_optional_commit, fn (result) { result == nothing }, ["a"]) + then just(["fallback"]) + }) + == just(["fallback"]) + ); + + assert(parse_with_meaning(parse_many, fn (result) { result == [] }, ["a"]) == []); + assert( + ({ + parse_with_meaning(parse_many_commit, fn (result) { result == [] }, ["a"]) + then [["fallback"]] + }) + == [["fallback"]] + ); + + assert(parse_with_meaning(parse_some, fn (result) { result == [["a"]] }, ["a", "a"]) == [["a"]]); + assert( + ({ + parse_with_meaning(parse_some_commit, fn (result) { result == [["a"]] }, ["a", "a"]) + then [["fallback"]] + }) + == [["fallback"]] + ); + + assert(parse_complete(parse_optional_overlap, ["a"]) == #(nothing, ["a"])); + assert( + ({ + parse_complete(parse_optional_overlap_commit, ["a"]) + then #(nothing, ["fallback"]) + }) + == #(nothing, ["fallback"]) + ); + + assert(parse_complete(parse_many_overlap, ["a"]) == #([], ["a"])); + assert( + ({ + parse_complete(parse_many_overlap_commit, ["a"]) + then #([], ["fallback"]) + }) + == #([], ["fallback"]) + ); + + assert(parse_complete(parse_some_overlap, ["a", "a"]) == #([["a"]], ["a"])); + assert( + ({ + parse_complete(parse_some_overlap_commit, ["a", "a"]) + then #([], ["fallback"]) + }) + == #([], ["fallback"]) + ) } } \ No newline at end of file From 01a5e2be18cb6c4bc60dcaf4c715ad004b4ebf71 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Tue, 19 May 2026 18:35:31 +0100 Subject: [PATCH 4/5] added cases for MINEXP_TYPE_CUT even if unused --- src/minlam_annotate.c | 10 ++++++++++ src/minlam_foldCmp.c | 10 ++++++++++ src/minlam_foldIff.c | 10 ++++++++++ src/minlam_foldVec.c | 10 ++++++++++ src/minlam_inline.c | 10 ++++++++++ 5 files changed, 50 insertions(+) diff --git a/src/minlam_annotate.c b/src/minlam_annotate.c index 5cff4c2e..fd5c3aaa 100644 --- a/src/minlam_annotate.c +++ b/src/minlam_annotate.c @@ -468,6 +468,16 @@ static MinExp *annotateMinExp(MinExp *node, IntMap *context) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = annotateMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_CHARACTER: { // character break; diff --git a/src/minlam_foldCmp.c b/src/minlam_foldCmp.c index add37d6f..f1d58a00 100644 --- a/src/minlam_foldCmp.c +++ b/src/minlam_foldCmp.c @@ -534,6 +534,16 @@ MinExp *foldCmpMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = foldCmpMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_DONE: { // int break; diff --git a/src/minlam_foldIff.c b/src/minlam_foldIff.c index 26aa7dc6..05753109 100644 --- a/src/minlam_foldIff.c +++ b/src/minlam_foldIff.c @@ -444,6 +444,16 @@ MinExp *foldIffMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = foldIffMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_DONE: { // int break; diff --git a/src/minlam_foldVec.c b/src/minlam_foldVec.c index 29c9daa7..e7cd7389 100644 --- a/src/minlam_foldVec.c +++ b/src/minlam_foldVec.c @@ -462,6 +462,16 @@ MinExp *foldVecMinExp(MinExp *node) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = foldVecMinExp(variant); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_DONE: { // int break; diff --git a/src/minlam_inline.c b/src/minlam_inline.c index 2cbe238a..9b8be4b7 100644 --- a/src/minlam_inline.c +++ b/src/minlam_inline.c @@ -504,6 +504,16 @@ MinExp *inlineMinExp(MinExp *node, BuiltIns *builtIns) { } break; } + case MINEXP_TYPE_CUT: { + // MinExp + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = inlineMinExp(variant, builtIns); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } + break; + } case MINEXP_TYPE_DONE: { // int break; From ea2853d195a3cbc57d384d6814a5209e96de9dd9 Mon Sep 17 00:00:00 2001 From: Bill Hails Date: Tue, 19 May 2026 19:18:38 +0100 Subject: [PATCH 5/5] fix potential latent bugs in helpers --- src/minlam_isSimple.c | 129 ++++++++++++------------------------------ src/minlam_occurs.c | 86 ++++++++++------------------ src/minlam_size.c | 4 +- src/minlam_substCs.c | 50 +++++----------- 4 files changed, 82 insertions(+), 187 deletions(-) diff --git a/src/minlam_isSimple.c b/src/minlam_isSimple.c index 2588e671..fc3be686 100644 --- a/src/minlam_isSimple.c +++ b/src/minlam_isSimple.c @@ -163,101 +163,44 @@ static bool isSimpleMinExp(MinExp *node, Context context) { if (node == NULL) return true; switch (node->type) { - case MINEXP_TYPE_AMB: { - // MinAmb - MinAmb *variant = getMinExp_Amb(node); - return isSimpleMinAmb(variant, context); - } - case MINEXP_TYPE_APPLY: { - // MinApply - MinApply *variant = getMinExp_Apply(node); - return isSimpleMinApply(variant, context); - } - case MINEXP_TYPE_ARGS: { - // MinExprList - MinExprList *variant = getMinExp_Args(node); - return isSimpleMinExprList(variant, context); - } - case MINEXP_TYPE_AVAR: { - // MinAnnotatedVar - return true; - } - case MINEXP_TYPE_BACK: { - // void_ptr - return true; - } - case MINEXP_TYPE_BIGINTEGER: { - // MaybeBigInt - return true; - } - case MINEXP_TYPE_BINDINGS: { - // MinBindings - MinBindings *variant = getMinExp_Bindings(node); - return isSimpleMinBindings(variant, context); - } - case MINEXP_TYPE_CALLCC: { - // MinExp - MinExp *variant = getMinExp_CallCC(node); - return isSimpleMinExp(variant, context); - } - case MINEXP_TYPE_CHARACTER: { - // character - return true; - } - case MINEXP_TYPE_COND: { - // MinCond - MinCond *variant = getMinExp_Cond(node); - return isSimpleMinCond(variant, context); - } - case MINEXP_TYPE_DONE: { - // int + case MINEXP_TYPE_AMB: + return isSimpleMinAmb(getMinExp_Amb(node), context); + case MINEXP_TYPE_APPLY: + return isSimpleMinApply(getMinExp_Apply(node), context); + case MINEXP_TYPE_ARGS: + return isSimpleMinExprList(getMinExp_Args(node), context); + case MINEXP_TYPE_BINDINGS: + return isSimpleMinBindings(getMinExp_Bindings(node), context); + case MINEXP_TYPE_CALLCC: + return isSimpleMinExp(getMinExp_CallCC(node), context); + case MINEXP_TYPE_CUT: + return isSimpleMinExp(getMinExp_Cut(node), context); + case MINEXP_TYPE_COND: + return isSimpleMinCond(getMinExp_Cond(node), context); + case MINEXP_TYPE_IFF: + return isSimpleMinIff(getMinExp_Iff(node), context); + case MINEXP_TYPE_LAM: + return isSimpleMinLam(getMinExp_Lam(node), context); + case MINEXP_TYPE_LETREC: + return isSimpleMinLetRec(getMinExp_LetRec(node), context); + case MINEXP_TYPE_MAKEVEC: + return isSimpleMinExprList(getMinExp_MakeVec(node), context); + case MINEXP_TYPE_MATCH: + return isSimpleMinMatch(getMinExp_Match(node), context); + case MINEXP_TYPE_PRIM: + return isSimpleMinPrimApp(getMinExp_Prim(node), context); + case MINEXP_TYPE_SEQUENCE: + return isSimpleMinExprList(getMinExp_Sequence(node), context); + case MINEXP_TYPE_DONE: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_STDINT: + case MINEXP_TYPE_VAR: + case MINEXP_TYPE_AVAR: + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_BIGINTEGER: return true; - } - case MINEXP_TYPE_IFF: { - // MinIff - MinIff *variant = getMinExp_Iff(node); - return isSimpleMinIff(variant, context); - } - case MINEXP_TYPE_LAM: { - // MinLam - MinLam *variant = getMinExp_Lam(node); - return isSimpleMinLam(variant, context); - } - case MINEXP_TYPE_LETREC: { - // MinLetRec - MinLetRec *variant = getMinExp_LetRec(node); - return isSimpleMinLetRec(variant, context); - } - case MINEXP_TYPE_MAKEVEC: { - // MinExprList - MinExprList *variant = getMinExp_MakeVec(node); - return isSimpleMinExprList(variant, context); - } - case MINEXP_TYPE_MATCH: { - // MinMatch - MinMatch *variant = getMinExp_Match(node); - return isSimpleMinMatch(variant, context); - } - case MINEXP_TYPE_PRIM: { - // MinPrimApp - MinPrimApp *variant = getMinExp_Prim(node); - return isSimpleMinPrimApp(variant, context); - } - case MINEXP_TYPE_SEQUENCE: { - // MinExprList - MinExprList *variant = getMinExp_Sequence(node); - return isSimpleMinExprList(variant, context); - } - case MINEXP_TYPE_STDINT: { - // int - return true; - } - case MINEXP_TYPE_VAR: { - // HashSymbol - return true; - } default: - cant_happen("unrecognized MinExp type %d", node->type); + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } } diff --git a/src/minlam_occurs.c b/src/minlam_occurs.c index 8f845c00..8dfc5f32 100644 --- a/src/minlam_occurs.c +++ b/src/minlam_occurs.c @@ -151,69 +151,41 @@ bool occursMinExp(MinExp *node, SymbolSet *targets) { return false; } switch (node->type) { - case MINEXP_TYPE_AMB: { - MinAmb *variant = getMinExp_Amb(node); - return occursMinAmb(variant, targets); - } - case MINEXP_TYPE_APPLY: { - MinApply *variant = getMinExp_Apply(node); - return occursMinApply(variant, targets); - } - case MINEXP_TYPE_BACK: { - return false; - } - case MINEXP_TYPE_BIGINTEGER: { - return false; - break; - } - case MINEXP_TYPE_CALLCC: { - MinExp *variant = getMinExp_CallCC(node); - return occursMinExp(variant, targets); - } - case MINEXP_TYPE_CHARACTER: { - return false; - } - case MINEXP_TYPE_COND: { - MinCond *variant = getMinExp_Cond(node); - return occursMinCond(variant, targets); - } - case MINEXP_TYPE_IFF: { - MinIff *variant = getMinExp_Iff(node); - return occursMinIff(variant, targets); - } - case MINEXP_TYPE_LAM: { - MinLam *variant = getMinExp_Lam(node); - return occursMinLam(variant, targets); - } - case MINEXP_TYPE_LETREC: { - MinLetRec *variant = getMinExp_LetRec(node); - return occursMinLetRec(variant, targets); - } - case MINEXP_TYPE_MAKEVEC: { - MinExprList *variant = getMinExp_MakeVec(node); - return occursMinExprList(variant, targets); - } - case MINEXP_TYPE_MATCH: { - MinMatch *variant = getMinExp_Match(node); - return occursMinMatch(variant, targets); - } - case MINEXP_TYPE_PRIM: { - MinPrimApp *variant = getMinExp_Prim(node); - return occursMinPrimApp(variant, targets); - } - case MINEXP_TYPE_SEQUENCE: { - MinExprList *variant = getMinExp_Sequence(node); - return occursMinExprList(variant, targets); - } - case MINEXP_TYPE_STDINT: { + case MINEXP_TYPE_AMB: + return occursMinAmb(getMinExp_Amb(node), targets); + case MINEXP_TYPE_APPLY: + return occursMinApply(getMinExp_Apply(node), targets); + case MINEXP_TYPE_CALLCC: + return occursMinExp(getMinExp_CallCC(node), targets); + case MINEXP_TYPE_CUT: + return occursMinExp(getMinExp_Cut(node), targets); + case MINEXP_TYPE_COND: + return occursMinCond(getMinExp_Cond(node), targets); + case MINEXP_TYPE_IFF: + return occursMinIff(getMinExp_Iff(node), targets); + case MINEXP_TYPE_LAM: + return occursMinLam(getMinExp_Lam(node), targets); + case MINEXP_TYPE_LETREC: + return occursMinLetRec(getMinExp_LetRec(node), targets); + case MINEXP_TYPE_MAKEVEC: + return occursMinExprList(getMinExp_MakeVec(node), targets); + case MINEXP_TYPE_MATCH: + return occursMinMatch(getMinExp_Match(node), targets); + case MINEXP_TYPE_PRIM: + return occursMinPrimApp(getMinExp_Prim(node), targets); + case MINEXP_TYPE_SEQUENCE: + return occursMinExprList(getMinExp_Sequence(node), targets); + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_BIGINTEGER: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_STDINT: return false; - } case MINEXP_TYPE_VAR: { HashSymbol *var = getMinExp_Var(node); return getSymbolSet(targets, var); } default: - cant_happen("unrecognized MinExp type %d", node->type); + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } } diff --git a/src/minlam_size.c b/src/minlam_size.c index e545f6be..fc2512b5 100644 --- a/src/minlam_size.c +++ b/src/minlam_size.c @@ -167,6 +167,8 @@ int sizeMinExp(MinExp *node) { return sizeMinBindings(getMinExp_Bindings(node)); case MINEXP_TYPE_CALLCC: return sizeMinExp(getMinExp_CallCC(node)); + case MINEXP_TYPE_CUT: + return sizeMinExp(getMinExp_Cut(node)); case MINEXP_TYPE_COND: return sizeMinCond(getMinExp_Cond(node)); case MINEXP_TYPE_IFF: @@ -184,7 +186,7 @@ int sizeMinExp(MinExp *node) { case MINEXP_TYPE_SEQUENCE: return sizeMinExprList(getMinExp_Sequence(node)); default: - cant_happen("unrecognized MinExp type %d", node->type); + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } return 0; } diff --git a/src/minlam_substCs.c b/src/minlam_substCs.c index 31014d95..92634d63 100644 --- a/src/minlam_substCs.c +++ b/src/minlam_substCs.c @@ -400,7 +400,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { MinExp *result = node; switch (node->type) { case MINEXP_TYPE_AMB: { - // MinAmb MinAmb *variant = getMinExp_Amb(node); MinAmb *new_variant = substCsMinAmb(variant, context); if (new_variant != variant) { @@ -410,7 +409,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_APPLY: { - // MinApply MinApply *variant = getMinExp_Apply(node); MinApply *new_variant = substCsMinApply(variant, context); if (new_variant != variant) { @@ -420,7 +418,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_ARGS: { - // MinExprList MinExprList *variant = getMinExp_Args(node); MinExprList *new_variant = substCsMinExprList(variant, context); if (new_variant != variant) { @@ -430,7 +427,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_AVAR: { - // MinAnnotatedVar MinAnnotatedVar *variant = getMinExp_Avar(node); MinAnnotatedVar *new_variant = substCsMinAnnotatedVar(variant, context); if (new_variant != variant) { @@ -439,16 +435,7 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { } break; } - case MINEXP_TYPE_BACK: { - // void_ptr - break; - } - case MINEXP_TYPE_BIGINTEGER: { - // MaybeBigInt - break; - } case MINEXP_TYPE_BINDINGS: { - // MinBindings MinBindings *variant = getMinExp_Bindings(node); MinBindings *new_variant = substCsMinBindings(variant, context); if (new_variant != variant) { @@ -458,7 +445,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_CALLCC: { - // MinExp MinExp *variant = getMinExp_CallCC(node); MinExp *new_variant = substCsMinExp(variant, context); if (new_variant != variant) { @@ -467,12 +453,16 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { } break; } - case MINEXP_TYPE_CHARACTER: { - // character + case MINEXP_TYPE_CUT: { + MinExp *variant = getMinExp_Cut(node); + MinExp *new_variant = substCsMinExp(variant, context); + if (new_variant != variant) { + PROTECT(new_variant); + result = newMinExp_Cut(CPI(node), new_variant); + } break; } case MINEXP_TYPE_COND: { - // MinCond MinCond *variant = getMinExp_Cond(node); MinCond *new_variant = substCsMinCond(variant, context); if (new_variant != variant) { @@ -481,12 +471,7 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { } break; } - case MINEXP_TYPE_DONE: { - // int - break; - } case MINEXP_TYPE_IFF: { - // MinIff MinIff *variant = getMinExp_Iff(node); MinIff *new_variant = substCsMinIff(variant, context); if (new_variant != variant) { @@ -496,7 +481,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_LAM: { - // MinLam MinLam *variant = getMinExp_Lam(node); MinLam *new_variant = substCsMinLam(variant, context); if (new_variant != variant) { @@ -506,7 +490,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_LETREC: { - // MinLetRec MinLetRec *variant = getMinExp_LetRec(node); MinLetRec *new_variant = substCsMinLetRec(variant, context); if (new_variant != variant) { @@ -516,7 +499,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_MAKEVEC: { - // MinExprList MinExprList *variant = getMinExp_MakeVec(node); MinExprList *new_variant = substCsMinExprList(variant, context); if (new_variant != variant) { @@ -526,7 +508,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_MATCH: { - // MinMatch MinMatch *variant = getMinExp_Match(node); MinMatch *new_variant = substCsMinMatch(variant, context); if (new_variant != variant) { @@ -536,7 +517,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_PRIM: { - // MinPrimApp MinPrimApp *variant = getMinExp_Prim(node); MinPrimApp *new_variant = substCsMinPrimApp(variant, context); if (new_variant != variant) { @@ -546,7 +526,6 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { break; } case MINEXP_TYPE_SEQUENCE: { - // MinExprList MinExprList *variant = getMinExp_Sequence(node); MinExprList *new_variant = substCsMinExprList(variant, context); if (new_variant != variant) { @@ -555,16 +534,15 @@ MinExp *substCsMinExp(MinExp *node, MinExpTable *context) { } break; } - case MINEXP_TYPE_STDINT: { - // int + case MINEXP_TYPE_BACK: + case MINEXP_TYPE_BIGINTEGER: + case MINEXP_TYPE_CHARACTER: + case MINEXP_TYPE_DONE: + case MINEXP_TYPE_STDINT: + case MINEXP_TYPE_VAR: break; - } - case MINEXP_TYPE_VAR: { - // HashSymbol - break; - } default: - cant_happen("unrecognized MinExp type %d", node->type); + cant_happen("unrecognized MinExp type %s", minExpTypeName(node->type)); } UNPROTECT(save); LEAVE(substCsMinExp);