Compare commits

...

3 Commits

Author SHA1 Message Date
James Eversole
42fce0ae43 Drop unreachable cases of updateDepth
All checks were successful
Test and Build / test (push) Successful in 2m27s
Test and Build / build (push) Successful in 1m39s
2025-01-21 16:16:04 -06:00
James Eversole
51b1eb070f Add more explicit error handling for mismatched groupings 2025-01-21 16:06:10 -06:00
James Eversole
c2e5a8985a Inline pattern matching in Parser 2025-01-21 14:21:47 -06:00
3 changed files with 95 additions and 83 deletions

View File

@ -57,7 +57,12 @@ levelOrderToString = (\s : toLineString (levelOrderTraversal s))
flatten = foldl (\acc x : lconcat acc x) "" flatten = foldl (\acc x : lconcat acc x) ""
flatLOT = (\s : lconcat (t 10 t) (flatten (levelOrderToString s))) flatLOT = (\s : lconcat (t 10 t) (flatten (levelOrderToString s)))
exampleOne = flatLOT [("1") [("2") [("4") t t] t] [("3") [("5") t t] [("6") t t]]] exampleOne = flatLOT [("1")
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]]] [("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

View File

@ -12,7 +12,8 @@ import Text.Megaparsec.Error (ParseErrorBundle, errorBundlePretty)
import qualified Data.Set as Set import qualified Data.Set as Set
data PState = PState data PState = PState
{ depth :: Int { parenDepth :: Int
, bracketDepth :: Int
} deriving (Show) } deriving (Show)
type ParserM = StateT PState (Parsec Void [LToken]) type ParserM = StateT PState (Parsec Void [LToken])
@ -24,24 +25,33 @@ satisfyM f = do
return token return token
updateDepth :: LToken -> PState -> PState updateDepth :: LToken -> PState -> PState
updateDepth LOpenParen st = st { depth = depth st + 1 } updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 }
updateDepth LCloseParen st = st { depth = max 0 (depth st - 1) } updateDepth LOpenBracket st = st { bracketDepth = bracketDepth st + 1 }
updateDepth LCloseParen st = st { parenDepth = parenDepth st - 1 }
updateDepth LCloseBracket st = st { bracketDepth = bracketDepth st - 1 }
updateDepth _ st = st updateDepth _ st = st
topLevelNewline :: ParserM () topLevelNewline :: ParserM ()
topLevelNewline = do topLevelNewline = do
st <- get st <- get
if depth st == 0 if parenDepth st == 0 && bracketDepth st == 0
then void (satisfyM (== LNewline)) 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 :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
parseProgram tokens = 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 :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
parseSingleExpr tokens = 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 :: String -> [TricuAST]
parseTricu input = parseTricu input =
@ -49,7 +59,7 @@ parseTricu input =
[] -> [] [] -> []
toks -> toks ->
case parseProgram toks of case parseProgram toks of
Left err -> error (handleParseError err) Left err -> errorWithoutStackTrace (handleParseError err)
Right asts -> asts Right asts -> asts
parseSingle :: String -> TricuAST parseSingle :: String -> TricuAST
@ -58,7 +68,7 @@ parseSingle input =
[] -> SEmpty [] -> SEmpty
toks -> toks ->
case parseSingleExpr toks of case parseSingleExpr toks of
Left err -> error (handleParseError err) Left err -> errorWithoutStackTrace (handleParseError err)
Right ast -> ast Right ast -> ast
parseProgramM :: ParserM [TricuAST] parseProgramM :: ParserM [TricuAST]
@ -75,10 +85,13 @@ scnParserM :: ParserM ()
scnParserM = skipMany $ do scnParserM = skipMany $ do
t <- lookAhead anySingle t <- lookAhead anySingle
st <- get st <- get
if depth st > 0 && isNewline t if | (parenDepth st > 0 || bracketDepth st > 0) && case t of
then void (satisfyM isNewline) LNewline -> True
else _ -> False -> void $ satisfyM $ \case
fail "In paren context or no space token" <|> empty LNewline -> True
_ -> False
| otherwise -> fail "In nested context or no space token" <|> empty
eofM :: ParserM () eofM :: ParserM ()
eofM = lift eof eofM = lift eof
@ -96,18 +109,27 @@ parseExpressionM = choice
parseFunctionM :: ParserM TricuAST parseFunctionM :: ParserM TricuAST
parseFunctionM = do parseFunctionM = do
LIdentifier name <- satisfyM isIdentifier LIdentifier name <- satisfyM $ \case
args <- many (satisfyM isIdentifier) LIdentifier _ -> True
_ -> False
args <- many $ satisfyM $ \case
LIdentifier _ -> True
_ -> False
_ <- satisfyM (== LAssign) _ <- satisfyM (== LAssign)
scnParserM scnParserM
body <- parseExpressionM body <- parseExpressionM
pure (SFunc name (map getIdentifier args) body) pure (SFunc name (map getIdentifier args) body)
parseLambdaM :: ParserM TricuAST parseLambdaM :: ParserM TricuAST
parseLambdaM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do parseLambdaM =
between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ do
_ <- satisfyM (== LBackslash) _ <- satisfyM (== LBackslash)
param <- satisfyM isIdentifier param <- satisfyM $ \case
rest <- many (satisfyM isIdentifier) LIdentifier _ -> True
_ -> False
rest <- many $ satisfyM $ \case
LIdentifier _ -> True
_ -> False
_ <- satisfyM (== LColon) _ <- satisfyM (== LColon)
scnParserM scnParserM
body <- parseLambdaExpressionM body <- parseLambdaExpressionM
@ -158,8 +180,10 @@ parseAtomicBaseM = choice
parseTreeLeafM :: ParserM TricuAST parseTreeLeafM :: ParserM TricuAST
parseTreeLeafM = do parseTreeLeafM = do
_ <- satisfyM isKeywordT _ <- satisfyM $ \case
notFollowedBy (lift (satisfy (== LAssign))) LKeywordT -> True
_ -> False
notFollowedBy $ lift $ satisfy (== LAssign)
pure TLeaf pure TLeaf
parseTreeTermM :: ParserM TricuAST parseTreeTermM :: ParserM TricuAST
@ -201,7 +225,10 @@ parseLiteralM = choice
parseListLiteralM :: ParserM TricuAST parseListLiteralM :: ParserM TricuAST
parseListLiteralM = do parseListLiteralM = do
_ <- satisfyM (== LOpenBracket) _ <- satisfyM (== LOpenBracket)
elements <- many parseListItemM elements <- many $ do
scnParserM
parseListItemM
scnParserM
_ <- satisfyM (== LCloseBracket) _ <- satisfyM (== LCloseBracket)
pure (SList elements) pure (SList elements)
@ -221,7 +248,10 @@ parseGroupedItemM = do
parseSingleItemM :: ParserM TricuAST parseSingleItemM :: ParserM TricuAST
parseSingleItemM = do parseSingleItemM = do
token <- satisfyM isListItem token <- satisfyM $ \case
LIdentifier _ -> True
LKeywordT -> True
_ -> False
case token of case token of
LIdentifier name -> pure (SVar name) LIdentifier name -> pure (SVar name)
LKeywordT -> pure TLeaf LKeywordT -> pure TLeaf
@ -229,71 +259,46 @@ parseSingleItemM = do
parseVarM :: ParserM TricuAST parseVarM :: ParserM TricuAST
parseVarM = do parseVarM = do
LIdentifier name <- satisfyM isIdentifier LIdentifier name <- satisfyM $ \case
LIdentifier _ -> True
_ -> False
if name == "t" || name == "__result" if name == "t" || name == "__result"
then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
else pure (SVar name) else pure (SVar name)
parseIntLiteralM :: ParserM TricuAST parseIntLiteralM :: ParserM TricuAST
parseIntLiteralM = do parseIntLiteralM = do
LIntegerLiteral value <- satisfyM isIntegerLiteral LIntegerLiteral value <- satisfyM $ \case
LIntegerLiteral _ -> True
_ -> False
pure (SInt value) pure (SInt value)
parseStrLiteralM :: ParserM TricuAST parseStrLiteralM :: ParserM TricuAST
parseStrLiteralM = do parseStrLiteralM = do
LStringLiteral value <- satisfyM isStringLiteral LStringLiteral value <- satisfyM $ \case
LStringLiteral _ -> True
_ -> False
pure (SStr value) pure (SStr value)
isKeywordT :: LToken -> Bool
isKeywordT LKeywordT = True
isKeywordT _ = False
isIdentifier :: LToken -> Bool
isIdentifier (LIdentifier _) = True
isIdentifier _ = False
isIntegerLiteral :: LToken -> Bool
isIntegerLiteral (LIntegerLiteral _) = True
isIntegerLiteral _ = False
isStringLiteral :: LToken -> Bool
isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False
isLiteral :: LToken -> Bool
isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral _ = False
isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True
isListItem LKeywordT = True
isListItem _ = False
isNewline :: LToken -> Bool
isNewline LNewline = True
isNewline _ = False
getIdentifier :: LToken -> String getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name getIdentifier (LIdentifier name) = name
getIdentifier _ = error "Expected identifier" getIdentifier _ = errorWithoutStackTrace "Expected identifier"
handleParseError :: ParseErrorBundle [LToken] Void -> String handleParseError :: ParseErrorBundle [LToken] Void -> String
handleParseError bundle = handleParseError bundle =
let errors = bundleErrors bundle let errors = bundleErrors bundle
errorList = Data.List.NonEmpty.toList errors formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
formattedErrs = map showError errorList in unlines ("Parse error(s) encountered:" : formattedErrors)
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)
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"

View File

@ -18,6 +18,7 @@ executable tricu
src src
default-extensions: default-extensions:
DeriveDataTypeable DeriveDataTypeable
LambdaCase
MultiWayIf MultiWayIf
OverloadedStrings OverloadedStrings
ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC ghc-options: -threaded -rtsopts -with-rtsopts=-N -optl-pthread -fPIC
@ -44,6 +45,7 @@ test-suite tricu-tests
hs-source-dirs: test, src hs-source-dirs: test, src
default-extensions: default-extensions:
DeriveDataTypeable DeriveDataTypeable
LambdaCase
MultiWayIf MultiWayIf
OverloadedStrings OverloadedStrings
build-depends: build-depends: