diff --git a/demos/LevelOrderTraversal.tri b/demos/LevelOrderTraversal.tri index 1c2d096..7681b28 100644 --- 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 index 513a781..c9faf52 100644 --- 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"