Improve Core parser error handling (#3300)

* Use `CoreError` for errors unrelated to parsing proper (e.g. scoping errors like undeclared identifier) * Adds negative parsing tests * Fixes parsing of side-conditions in match branches * Fixes a bug in redundant pattern detection with side-conditions
anoma · Feb 3, 2025 · f3e1588 · f3e1588
1 parent ec0003c
commit f3e1588
Show file tree

Hide file tree

Showing 46 changed files with 545 additions and 225 deletions.
diff --git a/app/Commands/Dev/Core/Repl.hs b/app/Commands/Dev/Core/Repl.hs
@@ -22,7 +22,7 @@ runCommand opts = do
   showReplWelcome
   runRepl opts mempty
 
-parseText :: Core.InfoTable -> Text -> Either Core.MegaparsecError (Core.InfoTable, Maybe Core.Node)
+parseText :: Core.InfoTable -> Text -> Either JuvixError (Core.InfoTable, Maybe Core.Node)
 parseText = Core.runParser replPath defaultModuleId
 
 runRepl :: forall r. (Members '[EmbedIO, App] r) => CoreReplOptions -> Core.InfoTable -> Sem r ()
@@ -40,7 +40,7 @@ runRepl opts tab = do
       ':' : 'p' : ' ' : s' ->
         case parseText tab (fromString s') of
           Left err -> do
-            printJuvixError (JuvixError err)
+            printJuvixError err
             runRepl opts tab
           Right (tab', Just node) -> do
             renderStdOut (Core.ppOut opts node)
@@ -51,7 +51,7 @@ runRepl opts tab = do
       ':' : 'e' : ' ' : s' ->
         case parseText tab (fromString s') of
           Left err -> do
-            printJuvixError (JuvixError err)
+            printJuvixError err
             runRepl opts tab
           Right (tab', Just node) ->
             replEval True tab' node
@@ -60,7 +60,7 @@ runRepl opts tab = do
       ':' : 'n' : ' ' : s' ->
         case parseText tab (fromString s') of
           Left err -> do
-            printJuvixError (JuvixError err)
+            printJuvixError err
             runRepl opts tab
           Right (tab', Just node) ->
             replNormalize tab' node
@@ -69,7 +69,7 @@ runRepl opts tab = do
       ':' : 't' : ' ' : s' ->
         case parseText tab (fromString s') of
           Left err -> do
-            printJuvixError (JuvixError err)
+            printJuvixError err
             runRepl opts tab
           Right (tab', Just node) ->
             replType tab' node
@@ -80,7 +80,7 @@ runRepl opts tab = do
         sf <- someBaseToAbs' (someFile f)
         case Core.runParser sf defaultModuleId mempty s' of
           Left err -> do
-            printJuvixError (JuvixError err)
+            printJuvixError err
             runRepl opts tab
           Right (tab', mnode) -> case mnode of
             Nothing -> runRepl opts tab'
@@ -90,7 +90,7 @@ runRepl opts tab = do
       _ ->
         case parseText tab s of
           Left err -> do
-            printJuvixError (JuvixError err)
+            printJuvixError err
             runRepl opts tab
           Right (tab', Just node) ->
             replEval False tab' node

diff --git a/src/Juvix/Compiler/Core/Extra/Base.hs b/src/Juvix/Compiler/Core/Extra/Base.hs
@@ -405,6 +405,18 @@ isPatConstr = \case
   PatConstr {} -> True
   PatWildcard {} -> False
 
+{------------------------------------------------------------------------}
+{- match branch -}
+
+isMatchBranchRhsExpression :: MatchBranch -> Bool
+isMatchBranchRhsExpression MatchBranch {..} =
+  case _matchBranchRhs of
+    MatchBranchRhsExpression {} -> True
+    MatchBranchRhsIfs {} -> False
+
+isMatchBranchRhsIf :: MatchBranch -> Bool
+isMatchBranchRhsIf = not . isMatchBranchRhsExpression
+
 {------------------------------------------------------------------------}
 {- generic Node destruction -}
 

diff --git a/src/Juvix/Compiler/Core/Transformation/DetectConstantSideConditions.hs b/src/Juvix/Compiler/Core/Transformation/DetectConstantSideConditions.hs
@@ -35,7 +35,7 @@ detectConstantSideConditions md = mapAllNodesM (umapM go) md
                 Just ifs0' -> return $ Just $ set matchBranchRhs (MatchBranchRhsIfs ifs0') br
             SideIfBranch {..} : ifs1' -> do
               fCoverage <- asks (^. optCheckCoverage)
-              unless (not fCoverage || null ifs1') $
+              when (fCoverage && not (null ifs1')) $
                 throw
                   CoreError
                     { _coreErrorMsg = "Redundant side condition",

diff --git a/src/Juvix/Compiler/Core/Transformation/DetectRedundantPatterns.hs b/src/Juvix/Compiler/Core/Transformation/DetectRedundantPatterns.hs
@@ -40,7 +40,7 @@ goDetectRedundantPatterns md node = case node of
     defaultLoc = singletonInterval (mkInitialLoc mockFile)
 
     checkMatch :: Match -> Sem r ()
-    checkMatch Match {..} = case _matchBranches of
+    checkMatch Match {..} = case dropWhile isMatchBranchRhsIf $ _matchBranches of
       [] -> return ()
       MatchBranch {..} : brs -> go [toList _matchBranchPatterns] brs
       where