Compare commits

..

No commits in common. "42fce0ae43af26b096c4fd28c6e895d9b8538baf" and "9d7e4daa4160ea80c0bbf0666bbc2c850c80e137" have entirely different histories.

3 changed files with 83 additions and 95 deletions

View File

@ -57,12 +57,7 @@ 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]]]
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]]]
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
exampleOne

View File

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