Inline pattern matching in Parser

This commit is contained in:
James Eversole 2025-01-21 14:21:47 -06:00
parent 9d7e4daa41
commit c2e5a8985a
2 changed files with 46 additions and 52 deletions

View File

@ -75,10 +75,12 @@ 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 | depth 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 paren context or no space token" <|> empty
eofM :: ParserM () eofM :: ParserM ()
eofM = lift eof eofM = lift eof
@ -96,18 +98,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 +169,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
@ -221,7 +234,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,51 +245,27 @@ 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 _ = error "Expected identifier"

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: