commit 83dad2c56be7acfafbd66987d5214f66ca4660cb
parent 962a100f533a1540d5c69c9b578ea998b52889e8
Author: James Eversole <james@eversole.co>
Date: Tue, 21 Jan 2025 16:06:10 -0600
Add more explicit error handling for mismatched groupings
Diffstat:
2 files changed, 56 insertions(+), 34 deletions(-)
diff --git a/demos/LevelOrderTraversal.tri b/demos/LevelOrderTraversal.tri
@@ -57,7 +57,12 @@ levelOrderToString = (\s : toLineString (levelOrderTraversal s))
flatten = foldl (\acc x : lconcat acc x) ""
flatLOT = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
-exampleOne = flatLOT [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]]
-exampleTwo = flatLOT [("1") [("2") [("4") [("8") t t] [("9") t t]] [("6") [("10") t t] [("12") t t]]] [("3") [("5") [("11") t t] t] [("7") t t]]]
+exampleOne = flatLOT [("1")
+ [("2") [("4") t t] t]
+ [("3") [("5") t t] [("6") t t]]]
-exampleOne
+exampleTwo = flatLOT [[("1")
+ [("2") [("4") [("8") t t] [("9") t t]] [("6") [("10") t t] [("12") t t]]]
+ [("3") [("5") [("11") t t] t] [("7") t t]]]
+
+exampleTwo
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -12,7 +12,8 @@ import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
import qualified Data.Set as Set
data PState = PState
- { depth :: Int
+ { parenDepth :: Int
+ , bracketDepth :: Int
} deriving (Show)
type ParserM = StateT PState (Parsec Void [LToken])
@@ -24,24 +25,37 @@ satisfyM f = do
return token
updateDepth :: LToken -> PState -> PState
-updateDepth LOpenParen st = st { depth = depth st + 1 }
-updateDepth LCloseParen st = st { depth = max 0 (depth st - 1) }
-updateDepth _ st = st
+updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
+updateDepth LCloseParen st
+ | parenDepth st > 0 = st { parenDepth = parenDepth st - 1 }
+ | otherwise = errorWithoutStackTrace "Unmatched closing parentheses"
+updateDepth LOpenBracket st = st { bracketDepth = bracketDepth st + 1 }
+updateDepth LCloseBracket st
+ | bracketDepth st > 0 = st { bracketDepth = bracketDepth st - 1 }
+ | otherwise = errorWithoutStackTrace "Unmatched closing bracket"
+updateDepth _ st = st
topLevelNewline :: ParserM ()
topLevelNewline = do
st <- get
- if depth st == 0
+ if parenDepth st == 0 && bracketDepth st == 0
then void (satisfyM (== LNewline))
- else fail "Top-level exit in paren context"
+ else fail "Top-level exit in nested context (paren or bracket)"
parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
parseProgram tokens =
- runParser (evalStateT parseProgramM (PState 0)) "" tokens
+ runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
parseSingleExpr tokens =
- runParser (evalStateT (scnParserM *> parseExpressionM <* eofM) (PState 0)) "" tokens
+ runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" tokens
+
+finalizeDepth :: ParserM ()
+finalizeDepth = do
+ st <- get
+ case (parenDepth st, bracketDepth st) of
+ (0, 0) -> pure ()
+ (p, b) -> fail $ "Unmatched tokens: " ++ show (p, b)
parseTricu :: String -> [TricuAST]
parseTricu input =
@@ -49,7 +63,7 @@ parseTricu input =
[] -> []
toks ->
case parseProgram toks of
- Left err -> error (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError err)
Right asts -> asts
parseSingle :: String -> TricuAST
@@ -58,7 +72,7 @@ parseSingle input =
[] -> SEmpty
toks ->
case parseSingleExpr toks of
- Left err -> error (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> ast
parseProgramM :: ParserM [TricuAST]
@@ -75,12 +89,13 @@ scnParserM :: ParserM ()
scnParserM = skipMany $ do
t <- lookAhead anySingle
st <- get
- if | depth st > 0 && case t of
+ if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
LNewline -> True
_ -> False -> void $ satisfyM $ \case
LNewline -> True
_ -> False
- | otherwise -> fail "In paren context or no space token" <|> empty
+ | otherwise -> fail "In nested context or no space token" <|> empty
+
eofM :: ParserM ()
eofM = lift eof
@@ -214,7 +229,10 @@ parseLiteralM = choice
parseListLiteralM :: ParserM TricuAST
parseListLiteralM = do
_ <- satisfyM (== LOpenBracket)
- elements <- many parseListItemM
+ elements <- many $ do
+ scnParserM
+ parseListItemM
+ scnParserM
_ <- satisfyM (== LCloseBracket)
pure (SList elements)
@@ -268,24 +286,23 @@ parseStrLiteralM = do
getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name
-getIdentifier _ = error "Expected identifier"
+getIdentifier _ = errorWithoutStackTrace "Expected identifier"
handleParseError :: ParseErrorBundle [LToken] Void -> String
handleParseError bundle =
- let errors = bundleErrors bundle
- errorList = Data.List.NonEmpty.toList errors
- formattedErrs = map showError errorList
- in unlines ("Parse error(s) encountered:" : formattedErrs)
-
-showError :: ParseError [LToken] Void -> String
-showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
- "Parse error at offset " ++ show offset
- ++ ": unexpected token " ++ show tokenStream
- ++ ", expected one of " ++ show (Set.toList expected)
-showError (FancyError offset fancy) =
- "Parse error at offset " ++ show offset ++ ":\n "
- ++ unlines (map show (Set.toList fancy))
-showError (TrivialError offset Nothing expected) =
- "Parse error at offset " ++ show offset
- ++ ": expected one of " ++ show (Set.toList expected)
-
+ let errors = bundleErrors bundle
+ formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
+ in unlines ("Parse error(s) encountered:" : formattedErrors)
+
+formatError :: ParseError [LToken] Void -> String
+formatError (TrivialError offset unexpected expected) =
+ let unexpectedMsg = case unexpected of
+ Just x -> "unexpected token " ++ show x
+ Nothing -> "unexpected end of input"
+ expectedMsg = if null expected
+ then ""
+ else "expected " ++ show (Set.toList expected)
+ in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++
+ if null expectedMsg then "" else " " ++ expectedMsg
+formatError (FancyError offset _) =
+ "Parse error at offset " ++ show offset ++ ": unexpected FancyError"
