James/tricu
2
2
Fork 0
Code Issues 1 Pull Requests Actions Packages Projects Releases Wiki Activity

Add more explicit error handling for mismatched groupings

Browse Source
This commit is contained in:
James Eversole 2025-01-21 16:06:10 -06:00 committed by James Eversole
parent 962a100f53
commit 83dad2c56b
2 changed files with 55 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
demos/LevelOrderTraversal.tri
View File

@ -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

77
src/Parser.hs
View File

@ -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"