tuple edge case fixed

billhails · Apr 2, 2024 · 819c6ce · 819c6ce
1 parent 650197b
commit 819c6ce
Show file tree

Hide file tree

Showing 4 changed files with 65 additions and 7 deletions.
diff --git a/fn/liars.fn b/fn/liars.fn
@@ -27,6 +27,41 @@ let
         }
     }
 
+    fn sortBy(predicate, lst) {
+        let
+            fn full_sort {
+                ([]) { [] }
+                (first @ rest) {
+                    partition(first, rest, fn (lesser, greater) {
+                        partial_sort(lesser, first @ full_sort(greater))
+                    })
+                }
+            }
+            fn partial_sort {
+                (first @ rest, already_sorted) {
+                    partition(first, rest, fn (lesser, greater) {
+                        partial_sort(lesser, first @ partial_sort(greater, already_sorted))
+                    })
+                }
+                ([], sorted) { sorted }
+            }
+            fn partition(key, lst, kont) {
+                let fn helper {
+                    ([], lesser, greater) { kont(lesser, greater) }
+                    (first @ rest, lesser, greater) {
+                        if (predicate(key, first) == lt) {
+                            helper(rest, lesser, first @ greater)
+                        } else {
+                            helper(rest, first @ lesser, greater)
+                        }
+                    }
+                }
+                in helper(lst, [], [])
+            }
+        in
+            full_sort(lst)
+    }
+
     fn liars() {
         let
             ranks = [1, 2, 3, 4, 5];
@@ -41,7 +76,16 @@ let
             require((joan == 3) xor (ethel == 5));
             require((kitty == 2) xor (mary == 4));
             require((mary == 4) xor (betty == 1));
-            [betty, ethel, joan, kitty, mary]
+            sortBy(
+                fn (#(_, a), #(_, b)) { a <=> b },
+                [
+                    #("Betty", betty),
+                    #("Ethel", ethel),
+                    #("Joan", joan),
+                    #("Kitty", kitty),
+                    #("Mary", mary)
+                ]
+            )
     }
 in
     print(liars())
diff --git a/fn/listutils.fn b/fn/listutils.fn
@@ -146,7 +146,7 @@ let
         }
     }
 
-    fn sort(lst) {
+    fn sortBy(predicate, lst) {
         let
             fn full_sort {
                 ([]) { [] }
@@ -168,7 +168,7 @@ let
                 let fn helper {
                     ([], lesser, greater) { kont(lesser, greater) }
                     (first @ rest, lesser, greater) {
-                        if (key < first) {
+                        if (predicate(key, first) == lt) {
                             helper(rest, lesser, first @ greater)
                         } else {
                             helper(rest, first @ lesser, greater)
@@ -181,5 +181,7 @@ let
             full_sort(lst)
     }
 
+    sort = sortBy(fn (a, b) { a <=> b });
+
 in
     print(concat(take(3, ["well", " ", "hi", " ", "there"])))
diff --git a/src/lambda_substitution.c b/src/lambda_substitution.c
@@ -114,6 +114,12 @@ static LamList *performListSubstitutions(LamList *list, TpmcSubstitutionTable
     return list;
 }
 
+static LamTupleIndex *performTupleIndexSubstitutions(LamTupleIndex *tupleIndex,
+                                                     TpmcSubstitutionTable *substitutions) {
+    tupleIndex->exp = lamPerformSubstitutions(tupleIndex->exp, substitutions);
+    return tupleIndex;
+}
+
 static LamMakeVec *performMakeVecSubstitutions(LamMakeVec *makeVec, TpmcSubstitutionTable
                                                *substitutions) {
     ENTER(performMakeVecSubstitutions);
@@ -417,6 +423,10 @@ LamExp *lamPerformSubstitutions(LamExp *exp,
             exp->val.make_tuple =
                 performListSubstitutions(exp->val.make_tuple, substitutions);
             break;
+        case LAMEXP_TYPE_TUPLE_INDEX:
+            exp->val.tuple_index =
+                performTupleIndexSubstitutions(exp->val.tuple_index, substitutions);
+            break;
         default:
             cant_happen
                 ("unrecognized LamExp type %s", lamExpTypeName(exp->type));

diff --git a/src/tc_analyze.c b/src/tc_analyze.c
@@ -724,10 +724,12 @@ static TcType *analyzeLetRec(LamLetRec *letRec, TcEnv *env, TcNg *ng) {
         processLetRecBinding(bindings, env, ng);
     }
     // HACK! second pass through fixes up forward references
-    for (LamLetRecBindings *bindings = letRec->bindings; bindings != NULL;
-         bindings = bindings->next) {
-        if (isLambdaBinding(bindings)) {
-            processLetRecBinding(bindings, env, ng);
+    if (!hadErrors()) {
+        for (LamLetRecBindings *bindings = letRec->bindings; bindings != NULL;
+             bindings = bindings->next) {
+            if (isLambdaBinding(bindings)) {
+                processLetRecBinding(bindings, env, ng);
+            }
         }
     }
     TcType *res = analyzeExp(letRec->body, env, ng);