Compare commits
No commits in common. "42fce0ae43af26b096c4fd28c6e895d9b8538baf" and "9d7e4daa4160ea80c0bbf0666bbc2c850c80e137" have entirely different histories.
42fce0ae43
...
9d7e4daa41
@ -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
|
||||
|
147
src/Parser.hs
147
src/Parser.hs
@ -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"
|
||||
|
@ -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:
|
||||
|
Loading…
x
Reference in New Issue
Block a user