Cut cleanup

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
+
+$ 
+```

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 <type>`, `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 <ns> function <x>` and `import <ns> functions`.
+  * We want `import <ns> function <x>` and `import <ns> functions`. DONE mostly.
   * And `import <ns> typedef <x>` and `import <ns> 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.

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) {

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)) {

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)
                     }

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)
     }

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)

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");

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);
         }

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)
     }

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)) }

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")
+    }
+}

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)) }

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)",
     ]};