add test cases, and fix bug with addLocToTypeErr stripping context …

…stack
swarm-game · Dec 17, 2024 · e7fd090 · e7fd090
1 parent 11dc571
commit e7fd090
Show file tree

Hide file tree

Showing 2 changed files with 25 additions and 17 deletions.
diff --git a/src/swarm-lang/Swarm/Language/Typecheck.hs b/src/swarm-lang/Swarm/Language/Typecheck.hs
@@ -257,15 +257,14 @@ lookup loc x = do
 addLocToTypeErr ::
   ( Has (Throw ContextualTypeErr) sig m
   , Has (Catch ContextualTypeErr) sig m
-  , Has (Reader TCStack) sig m
   ) =>
   SrcLoc ->
   m a ->
   m a
 addLocToTypeErr l m =
   m `catchError` \case
-    CTE NoLoc _ te -> throwTypeErr l te
-    te -> throwError te
+    CTE NoLoc stk te -> throwError $ CTE l stk te
+    cte -> throwError cte
 
 ------------------------------------------------------------
 -- Dealing with variables: free variables, fresh variables,
@@ -895,7 +894,7 @@ infer s@(CSyntax l t cs) = addLocToTypeErr l $ case t of
   -- each time.
   SApp f x -> do
     -- Infer the type of the left-hand side and make sure it has a function type.
-    (f',argTy,resTy) <- withFrame l (TCAppL x) $ do
+    (f', argTy, resTy) <- withFrame l (TCAppL x) $ do
       f' <- infer f
       (argTy, resTy) <- decomposeFunTy f (Actual, f' ^. sType)
       pure (f', argTy, resTy)

diff --git a/test/unit/TestLanguagePipeline.hs b/test/unit/TestLanguagePipeline.hs
@@ -668,19 +668,28 @@ testLanguagePipeline =
                 "1:1: Undefined type U"
             )
         ]
-    , testCase
-        "Stop printing context after a definition. - #1336"
-        ( processCompare
-            (==)
-            "move; def x = move; say 3 end; move;"
-            "1:25: Type mismatch:\n  From context, expected `3` to have type `Text`,\n  but it actually has type `Int`\n\n  - While checking the argument to a function: say _\n  - While checking the definition of x"
-        )
-    , testCase
-        "Error inside function application + argument #2220"
-        ( process
-            "id 3 3"
-            "1:1: Unbound variable id\n\n  - While checking a function applied to an argument: _ 3\n  - While checking a function applied to an argument: _ 3"
-        )
+    , testGroup
+        "typechecking context stack"
+        [ testCase
+            "Stop printing context after a definition. - #1336"
+            ( processCompare
+                (==)
+                "move; def x = move; say 3 end; move;"
+                "1:25: Type mismatch:\n  From context, expected `3` to have type `Text`,\n  but it actually has type `Int`\n\n  - While checking the argument to a function: say _\n  - While checking the definition of x"
+            )
+        , testCase
+            "Error inside function application + argument #2220"
+            ( process
+                "id 3 3"
+                "1:1: Unbound variable id\n\n  - While checking a function applied to an argument: _ 3\n  - While checking a function applied to an argument: _ 3"
+            )
+        , testCase
+            "Error inside function application + argument #2220"
+            ( process
+                "(\\x. x) 7 8"
+                "1:1: Type mismatch:\n  From context, expected `(\\x. x) 7` to be a function,\n  but it actually has type `Int`\n\n  - While checking a function applied to an argument: _ 8"
+            )
+        ]
     , testGroup
         "let and def types"
         [ testCase