commit bb6af02a8489d0309f46de6c631bff001cb914b9
parent 189e0b3bed27597eb0acc56da3b25b9d18c2691e
Author: James Eversole <james@eversole.co>
Date: Sat, 16 May 2026 14:29:35 -0500
Sane parser rewrite
Diffstat:
7 files changed, 498 insertions(+), 344 deletions(-)
diff --git a/demos/interactionTrees/forkAwait.tri b/demos/interactionTrees/forkAwait.tri
@@ -6,9 +6,9 @@
-- fork spawns a concurrent task and returns a handle.
-- await blocks until the task completes and returns its value.
-worker = (msg :
+worker = msg :
bind (putStrLn (append "working: " msg)) (_ :
- pure (append msg "-result")))
+ pure (append msg "-result"))
main = io <|
(bind (fork (worker "job1")) (h1 :
diff --git a/demos/interactionTrees/greet.tri b/demos/interactionTrees/greet.tri
@@ -5,6 +5,6 @@
-- Greet and return a pure value.
-- putStrLn writes to stdout; pure lifts "done" into IO.
-main = io (bind
- (putStrLn (append "Hello, " "tricu"))
- (_ : pure ""))
+main = io <|
+ bind (putStrLn (append "Hello, " "tricu"))
+ (_ : pure "")
diff --git a/src/FileEval.hs b/src/FileEval.hs
@@ -51,7 +51,7 @@ evaluateFileResult filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError tokens err)
Right _ast -> do
processedAst <- preprocessFile filePath
let finalEnv = evalTricu Map.empty processedAst
@@ -64,7 +64,7 @@ evaluateFile filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError tokens err)
Right _ast -> do
ast <- preprocessFile filePath
pure $ evalTricu Map.empty ast
@@ -74,7 +74,7 @@ evaluateFileWithContext env filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError tokens err)
Right _ast -> do
ast <- preprocessFile filePath
pure $ evalTricu env ast
@@ -86,7 +86,7 @@ evaluateFileWithStore mconn env filePath = do
contents <- readFile filePath
let tokens = lexTricu contents
case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError tokens err)
Right _ast -> do
ast <- preprocessFile filePath
evalTricuWithStore mconn env ast
@@ -99,7 +99,7 @@ preprocessFile' seen base currentPath = do
contents <- readFile currentPath
let tokens = lexTricu contents
case parseProgram tokens of
- Left err -> errorWithoutStackTrace (handleParseError err)
+ Left err -> errorWithoutStackTrace (handleParseError tokens err)
Right ast ->
case processImports seen base currentPath ast of
Left err -> errorWithoutStackTrace err
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -46,6 +46,7 @@ tricuLexer = do
, openBracket
, closeBracket
, try arrowLeft
+ , try arrowRight
]
lexTricu :: String -> [LToken]
@@ -132,6 +133,9 @@ closeBracket = char ']' $> LCloseBracket
arrowLeft :: Lexer LToken
arrowLeft = string "<|" $> LArrowLeft
+arrowRight :: Lexer LToken
+arrowRight = string "|>" $> LArrowRight
+
lnewline :: Lexer LToken
lnewline = char '\n' $> LNewline
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -3,348 +3,427 @@ module Parser where
import Lexer
import Research
-import Control.Monad (void)
-import Control.Monad.State
-import Data.List.NonEmpty (toList)
-import Data.Void (Void)
+import Control.Monad (void)
+import Data.Void (Void)
import Text.Megaparsec
+import qualified Data.List.NonEmpty as NE
import qualified Data.Set as Set
-data PState = PState
- { parenDepth :: Int
- , bracketDepth :: Int
- } deriving (Show)
-
-type ParserM = StateT PState (Parsec Void [LToken])
-
-satisfyM :: (LToken -> Bool) -> ParserM LToken
-satisfyM f = do
- tok <- lift (satisfy f)
- modify' (updateDepth tok)
- return tok
-
-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 _ st = st
-
-topLevelNewline :: ParserM ()
-topLevelNewline = do
- st <- get
- if parenDepth st == 0 && bracketDepth st == 0
- then void (satisfyM (== LNewline))
- else fail "Top-level exit in nested context (paren or bracket)"
+type TokParser = Parsec Void [LToken]
-parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
-parseProgram toks =
- runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" toks
-
-parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
-parseSingleExpr toks =
- runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" toks
+data Context = Top | Nested
+ deriving (Eq, Show)
-finalizeDepth :: ParserM ()
-finalizeDepth = do
- st <- get
- case (parenDepth st, bracketDepth st) of
- (0, 0) -> pure ()
- (p, b) -> fail $ "Unmatched tokens: " ++ show (p, b)
+reservedNames :: Set.Set String
+reservedNames = Set.fromList ["t", "!result"]
parseTricu :: String -> [TricuAST]
parseTricu input =
- case lexTricu input of
- [] -> []
- toks ->
- case parseProgram toks of
- Left err -> errorWithoutStackTrace (handleParseError err)
- Right asts -> asts
+ let toks = lexTricu input
+ in case runParser programP "" toks of
+ Left err -> errorWithoutStackTrace (handleParseError toks err)
+ Right asts -> asts
parseSingle :: String -> TricuAST
parseSingle input =
- case lexTricu input of
- [] -> SEmpty
- toks ->
- case parseSingleExpr toks of
- Left err -> errorWithoutStackTrace (handleParseError err)
- Right ast -> ast
-
-parseProgramM :: ParserM [TricuAST]
-parseProgramM = do
- skipMany topLevelNewline
- importNodes <- many (do
- node <- parseImportM
- skipMany topLevelNewline
- return node)
- skipMany topLevelNewline
- exprs <- sepEndBy parseOneExpression (some topLevelNewline)
- skipMany topLevelNewline
- return (importNodes ++ exprs)
-
-parseImportM :: ParserM TricuAST
-parseImportM = do
- LImport filePath moduleName <- satisfyM isImport
- pure (SImport filePath moduleName)
+ let toks = lexTricu input
+ in case parseSingleExpr toks of
+ Left err -> errorWithoutStackTrace (handleParseError toks err)
+ Right ast -> ast
+
+parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
+parseProgram = runParser programP ""
+
+parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
+parseSingleExpr = runParser singleP ""
+
+programP :: TokParser [TricuAST]
+programP = do
+ skipTopNewlines
+ imports <- many (importP <* skipTopNewlines)
+ items <- manyItemsP
+ eof
+ pure (imports ++ items)
+
+singleP :: TokParser TricuAST
+singleP = do
+ skipTopNewlines
+ item <- topItemP
+ skipTopNewlines
+ eof
+ pure item
+
+manyItemsP :: TokParser [TricuAST]
+manyItemsP = do
+ skipTopNewlines
+ done <- atEndP
+ if done
+ then pure []
+ else do
+ item <- topItemP
+ skipTopNewlines
+ rest <- manyItemsP
+ pure (item : rest)
+
+topItemP :: TokParser TricuAST
+topItemP = do
+ toks <- getInput
+ case toks of
+ LIdentifier _ : LAssign : _ -> definitionP
+ _ -> exprTopP
+
+definitionP :: TokParser TricuAST
+definitionP = do
+ name <- identifierNameP
+ void (tok (== LAssign) "=")
+ skipNestedNewlines
+ body <- exprTopP
+ pure (SDef name [] body)
+
+importP :: TokParser TricuAST
+importP = do
+ t <- tok isImport "import"
+ case t of
+ LImport path ns -> pure (SImport path ns)
+ _ -> fail "internal parser error: expected import token"
where
isImport (LImport _ _) = True
isImport _ = False
-parseOneExpression :: ParserM TricuAST
-parseOneExpression = scnParserM *> parseExpressionM
-
-scnParserM :: ParserM ()
-scnParserM = skipMany $ do
- t <- lookAhead anySingle
- st <- get
- if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
- void $ satisfyM (== LNewline)
- | otherwise ->
- fail "In nested context or no space token" <|> empty
-
-eofM :: ParserM ()
-eofM = lift eof
-
-parseExpressionM :: ParserM TricuAST
-parseExpressionM = choice
- [ try parseFunctionM
- , try parseLambdaM
- , try parseLambdaExpressionM
- , try parseListLiteralM
- , try parseTreeTermM
- , try parseArrowLeftM
- , parseLiteralM
- ]
-
-parseFunctionM :: ParserM TricuAST
-parseFunctionM = do
- let ident = (\case LIdentifier _ -> True; _ -> False)
- LIdentifier name <- satisfyM ident
- args <- many $ satisfyM ident
- _ <- satisfyM (== LAssign)
- scnParserM
- body <- parseExpressionM
- pure (SDef name (map getIdentifier args) body)
-
-parseLambdaM :: ParserM TricuAST
-parseLambdaM = do
- let ident = (\case LIdentifier _ -> True; _ -> False)
- params <- some (satisfyM ident)
- _ <- satisfyM (== LColon)
- scnParserM
- body <- parseLambdaExpressionM
- pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
-
-parseLambdaExpressionM :: ParserM TricuAST
-parseLambdaExpressionM = choice
- [ try parseLambdaArrowLeftM
- , parseAtomicLambdaM
- ]
-
-parseAtomicLambdaM :: ParserM TricuAST
-parseAtomicLambdaM = choice
- [ try parseLambdaM
- , parseVarM
- , parseTreeLeafM
- , parseLiteralM
- , parseListLiteralM
- , between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
- ]
-
-parseApplicationM :: ParserM TricuAST
-parseApplicationM = do
- func <- parseAtomicBaseM
- scnParserM
- args <- many $ do
- scnParserM
- arg <- parseAtomicM
- return arg
- return $ foldl SApp func args
-
-parseLambdaApplicationM :: ParserM TricuAST
-parseLambdaApplicationM = do
- func <- parseAtomicLambdaM
- scnParserM
- args <- many $ do
- arg <- parseAtomicLambdaM
- scnParserM
- pure arg
- pure $ foldl SApp func args
-
-parseArrowLeftM :: ParserM TricuAST
-parseArrowLeftM = do
- left <- parseApplicationM
- mArrow <- optional (try $ do
- scnParserM
- satisfyM (== LArrowLeft))
- case mArrow of
- Nothing -> return left
- Just _ -> do
- skipMany (satisfyM (== LNewline))
- scnParserM
- right <- parseExpressionM
- return $ SApp left right
-
-parseLambdaArrowLeftM :: ParserM TricuAST
-parseLambdaArrowLeftM = do
- left <- parseLambdaApplicationM
- mArrow <- optional (try $ do
- scnParserM
- satisfyM (== LArrowLeft))
- case mArrow of
- Nothing -> return left
- Just _ -> do
- skipMany (satisfyM (== LNewline))
- scnParserM
- right <- parseLambdaExpressionM
- return $ SApp left right
-
-parseAtomicBaseM :: ParserM TricuAST
-parseAtomicBaseM = choice
- [ parseTreeLeafM
- , parseGroupedM
- ]
-
-parseTreeLeafM :: ParserM TricuAST
-parseTreeLeafM = do
- let keyword = (\case LKeywordT -> True; _ -> False)
- _ <- satisfyM keyword
- notFollowedBy $ lift $ satisfy (== LAssign)
- pure TLeaf
-
-parseTreeTermM :: ParserM TricuAST
-parseTreeTermM = do
- base <- parseTreeLeafOrParenthesizedM
- rest <- many parseTreeLeafOrParenthesizedM
- pure (foldl combine base rest)
+exprTopP :: TokParser TricuAST
+exprTopP = do
+ toks <- getInput
+ case lambdaHeadTop toks of
+ Just params -> lambdaP Top params
+ Nothing -> pipeTopP
+
+exprNestedP :: TokParser TricuAST
+exprNestedP = do
+ skipNestedNewlines
+ toks <- getInput
+ case lambdaHeadNested toks of
+ Just params -> lambdaP Nested params
+ Nothing -> pipeNestedP
+
+lambdaP :: Context -> [String] -> TokParser TricuAST
+lambdaP ctx params = do
+ consumeLambdaHead ctx params
+ body <- case ctx of
+ Top -> exprTopP
+ Nested -> exprNestedP
+ pure (foldr (\p acc -> SLambda [p] acc) body params)
+
+lambdaHeadTop :: [LToken] -> Maybe [String]
+lambdaHeadTop toks =
+ case collectIdentifiersNoNewlines toks of
+ (params@(_:_), LColon : _) -> Just params
+ _ -> Nothing
+
+lambdaHeadNested :: [LToken] -> Maybe [String]
+lambdaHeadNested toks =
+ case collectIdentifiersWithNewlines (dropNewlines toks) of
+ (params@(_:_), rest) ->
+ case dropNewlines rest of
+ LColon : _ -> Just params
+ _ -> Nothing
+ _ -> Nothing
+
+collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
+collectIdentifiersNoNewlines (LIdentifier name : rest) =
+ let (names, final) = collectIdentifiersNoNewlines rest
+ in (name : names, final)
+collectIdentifiersNoNewlines rest = ([], rest)
+
+collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken])
+collectIdentifiersWithNewlines (LIdentifier name : rest) =
+ let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
+ in (name : names, final)
+collectIdentifiersWithNewlines rest = ([], rest)
+
+consumeLambdaHead :: Context -> [String] -> TokParser ()
+consumeLambdaHead ctx params = do
+ case ctx of
+ Top -> pure ()
+ Nested -> skipNestedNewlines
+
+ mapM_ consumeParam params
+
+ case ctx of
+ Top -> pure ()
+ Nested -> skipNestedNewlines
+
+ void (tok (== LColon) ":")
+ skipNestedNewlines
where
- combine acc next
- | TLeaf <- acc = TStem next
- | TStem t <- acc = TFork t next
- | TFork _ _ <- acc = TFork acc next
- | otherwise = SApp acc next
-
-parseTreeLeafOrParenthesizedM :: ParserM TricuAST
-parseTreeLeafOrParenthesizedM = choice
- [ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM
- , parseTreeLeafM
- ]
-
-parseAtomicM :: ParserM TricuAST
-parseAtomicM = choice
- [ try parseLambdaM
- , parseVarM
- , parseTreeLeafM
- , parseListLiteralM
- , parseGroupedM
- , parseLiteralM
- ]
-
-parseGroupedM :: ParserM TricuAST
-parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $
- scnParserM *> parseExpressionM <* scnParserM
-
-parseLiteralM :: ParserM TricuAST
-parseLiteralM = choice
- [ parseIntLiteralM
- , parseStrLiteralM
- ]
-
-parseListLiteralM :: ParserM TricuAST
-parseListLiteralM = do
- _ <- satisfyM (== LOpenBracket)
- elements <- many $ do
- scnParserM
- parseListItemM
- scnParserM
- _ <- satisfyM (== LCloseBracket)
- pure (SList elements)
-
-parseListItemM :: ParserM TricuAST
-parseListItemM = choice
- [ parseGroupedItemM
- , parseListLiteralM
- , parseSingleItemM
- ]
-
-parseGroupedItemM :: ParserM TricuAST
-parseGroupedItemM = do
- _ <- satisfyM (== LOpenParen)
- inner <- parseExpressionM
- _ <- satisfyM (== LCloseParen)
- pure inner
-
-parseSingleItemM :: ParserM TricuAST
-parseSingleItemM = do
- tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
- if | LIdentifier name <- tok -> pure (SVar name Nothing)
- | tok == LKeywordT -> pure TLeaf
- | otherwise -> fail "Unexpected token in list item"
-
-parseVarM :: ParserM TricuAST
-parseVarM = do
- tok <- satisfyM (\case
- LNamespace _ -> True
- LIdentifier _ -> True
- LIdentifierWithHash _ _ -> True
- _ -> False)
-
- case tok of
- LNamespace ns -> do
- _ <- satisfyM (== LDot)
- LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
- pure $ SVar (ns ++ "." ++ name) Nothing
+ consumeParam _ = do
+ void identifierNameP
+ case ctx of
+ Top -> pure ()
+ Nested -> skipNestedNewlines
+
+data PipeOp = PipeBackward | PipeForward
+ deriving (Eq, Show)
+
+applyPipe :: TricuAST -> (PipeOp, TricuAST) -> TricuAST
+applyPipe acc (PipeBackward, rhs) =
+ SApp acc rhs
+
+applyPipe acc (PipeForward, rhs) =
+ SApp rhs acc
+
+pipeTopP :: TokParser TricuAST
+pipeTopP =
+ pipeChainP appTopP appNestedP
+
+pipeNestedP :: TokParser TricuAST
+pipeNestedP =
+ pipeChainP appNestedP appNestedP
+
+pipeChainP :: TokParser TricuAST -> TokParser TricuAST -> TokParser TricuAST
+pipeChainP parseFirst parseOperand = do
+ first <- parseFirst
+ rest <- many (try pipeSegmentP)
+ pure (foldl applyPipe first rest)
+ where
+ pipeSegmentP = do
+ skipNestedNewlines
+ op <- pipeOpP
+ skipNestedNewlines
+ rhs <- parseOperand
+ pure (op, rhs)
+
+pipeOpP :: TokParser PipeOp
+pipeOpP =
+ (tok (== LArrowLeft) "<|" *> pure PipeBackward)
+ <|> (tok (== LArrowRight) "|>" *> pure PipeForward)
+
+appTopP :: TokParser TricuAST
+appTopP = do
+ first <- atomTopP
+ appRestTopP first
+
+appRestTopP :: TricuAST -> TokParser TricuAST
+appRestTopP acc = do
+ mt <- peekP
+ case mt of
+ Just t | startsAtom t -> do
+ arg <- atomTopP
+ appRestTopP (SApp acc arg)
+ _ -> pure acc
+
+appNestedP :: TokParser TricuAST
+appNestedP = do
+ first <- atomNestedP
+ appRestNestedP first
+
+appRestNestedP :: TricuAST -> TokParser TricuAST
+appRestNestedP acc = do
+ skipNestedNewlines
+ mt <- peekP
+ case mt of
+ Just t | startsAtom t -> do
+ arg <- atomNestedP
+ appRestNestedP (SApp acc arg)
+ _ -> pure acc
+
+startsAtom :: LToken -> Bool
+startsAtom LOpenParen = True
+startsAtom LOpenBracket = True
+startsAtom (LIdentifier _) = True
+startsAtom (LIdentifierWithHash _ _) = True
+startsAtom (LNamespace _) = True
+startsAtom LKeywordT = True
+startsAtom (LIntegerLiteral _) = True
+startsAtom (LStringLiteral _) = True
+startsAtom _ = False
+
+atomTopP :: TokParser TricuAST
+atomTopP = do
+ toks <- getInput
+ case toks of
+ LOpenParen : _ -> groupedP
+ LOpenBracket : _ -> listP
+ LNamespace _ : LDot : _ -> namespacedVarP
+ LIdentifier _ : _ -> plainVarP
+ LIdentifierWithHash _ _ : _ -> plainVarP
+ LKeywordT : _ -> leafP
+ LIntegerLiteral _ : _ -> intP
+ LStringLiteral _ : _ -> strP
+ _ -> fail "expected expression atom"
+
+atomNestedP :: TokParser TricuAST
+atomNestedP = skipNestedNewlines *> atomTopP
+
+groupedP :: TokParser TricuAST
+groupedP = do
+ void (tok (== LOpenParen) "(")
+ skipNestedNewlines
+ expr <- exprNestedP
+ skipNestedNewlines
+ void (tok (== LCloseParen) ")")
+ pure expr
+
+listP :: TokParser TricuAST
+listP = do
+ void (tok (== LOpenBracket) "[")
+ skipNestedNewlines
+ xs <- listElementsP
+ skipNestedNewlines
+ void (tok (== LCloseBracket) "]")
+ pure (SList xs)
+
+listElementsP :: TokParser [TricuAST]
+listElementsP = do
+ skipNestedNewlines
+ mt <- peekP
+ case mt of
+ Just LCloseBracket -> pure []
+ Just t | startsAtom t -> do
+ x <- listElementP
+ xs <- listElementsP
+ pure (x : xs)
+ _ -> pure []
+
+listElementP :: TokParser TricuAST
+listElementP = do
+ toks <- getInput
+ case toks of
+ LOpenParen : _ -> groupedP
+ LOpenBracket : _ -> listP
+ LNamespace _ : LDot : _ -> namespacedVarP
+ LIdentifier _ : _ -> plainVarP
+ LIdentifierWithHash _ _ : _ -> plainVarP
+ LKeywordT : _ -> leafP
+ LIntegerLiteral _ : _ -> intP
+ LStringLiteral _ : _ -> strP
+ _ -> fail "expected list element"
+
+leafP :: TokParser TricuAST
+leafP = tok (== LKeywordT) "t" *> pure TLeaf
+
+plainVarP :: TokParser TricuAST
+plainVarP = do
+ t <- tok isVar "identifier"
+ case t of
+ LIdentifier name -> pure (SVar name Nothing)
+ LIdentifierWithHash name hash -> pure (SVar name (Just hash))
+ _ -> fail "internal parser error: expected identifier"
+ where
+ isVar (LIdentifier _) = True
+ isVar (LIdentifierWithHash _ _) = True
+ isVar _ = False
+
+namespacedVarP :: TokParser TricuAST
+namespacedVarP = do
+ nsTok <- tok isNamespace "namespace"
+ void (tok (== LDot) ".")
+ nameTok <- tok isVar "identifier"
+ case (nsTok, nameTok) of
+ (LNamespace ns, LIdentifier name) ->
+ pure (SVar (ns ++ "." ++ name) Nothing)
+ (LNamespace ns, LIdentifierWithHash name hash) ->
+ pure (SVar (ns ++ "." ++ name) (Just hash))
+ _ -> fail "internal parser error: expected namespaced identifier"
+ where
+ isNamespace (LNamespace _) = True
+ isNamespace _ = False
+
+ isVar (LIdentifier _) = True
+ isVar (LIdentifierWithHash _ _) = True
+ isVar _ = False
+
+intP :: TokParser TricuAST
+intP = do
+ t <- tok isInt "integer"
+ case t of
+ LIntegerLiteral n -> pure (SInt (fromIntegral n))
+ _ -> fail "internal parser error: expected integer"
+ where
+ isInt (LIntegerLiteral _) = True
+ isInt _ = False
+
+strP :: TokParser TricuAST
+strP = do
+ t <- tok isStr "string"
+ case t of
+ LStringLiteral s -> pure (SStr s)
+ _ -> fail "internal parser error: expected string"
+ where
+ isStr (LStringLiteral _) = True
+ isStr _ = False
+identifierNameP :: TokParser String
+identifierNameP = do
+ t <- tok isIdentifier "identifier"
+ case t of
LIdentifier name
- | name == "t" || name == "!result" ->
- fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
- | otherwise -> pure (SVar name Nothing)
-
- LIdentifierWithHash name hash ->
- if name == "t" || name == "!result"
- then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
- else pure (SVar name (Just hash))
-
- _ -> fail "Unexpected token while parsing variable"
-
-parseIntLiteralM :: ParserM TricuAST
-parseIntLiteralM = do
- let intL = (\case LIntegerLiteral _ -> True; _ -> False)
- tok <- satisfyM intL
- if | LIntegerLiteral value <- tok ->
- pure (SInt (fromIntegral value))
- | otherwise ->
- fail "Unexpected token while parsing integer literal"
-
-parseStrLiteralM :: ParserM TricuAST
-parseStrLiteralM = do
- let strL = (\case LStringLiteral _ -> True; _ -> False)
- tok <- satisfyM strL
- if | LStringLiteral value <- tok ->
- pure (SStr value)
- | otherwise ->
- fail "Unexpected token while parsing string literal"
-
-getIdentifier :: LToken -> String
-getIdentifier (LIdentifier name) = name
-getIdentifier _ = errorWithoutStackTrace "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)
-
-formatError :: ParseError [LToken] Void -> String
-formatError (TrivialError offset msgUnexpected expected) =
- let unexpectedMsg = case msgUnexpected 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"
+ | name `Set.member` reservedNames ->
+ fail ("reserved name cannot be used as identifier: " ++ name)
+ | otherwise ->
+ pure name
+ _ -> fail "internal parser error: expected identifier"
+ where
+ isIdentifier (LIdentifier _) = True
+ isIdentifier _ = False
+
+tok :: (LToken -> Bool) -> String -> TokParser LToken
+tok predicate expected = satisfy predicate <?> expected
+
+peekP :: TokParser (Maybe LToken)
+peekP = do
+ toks <- getInput
+ pure $ case toks of
+ [] -> Nothing
+ x : _ -> Just x
+
+atEndP :: TokParser Bool
+atEndP = null <$> getInput
+
+skipTopNewlines :: TokParser ()
+skipTopNewlines = skipMany (tok (== LNewline) "newline")
+
+skipNestedNewlines :: TokParser ()
+skipNestedNewlines = skipMany (tok (== LNewline) "newline")
+
+dropNewlines :: [LToken] -> [LToken]
+dropNewlines (LNewline : rest) = dropNewlines rest
+dropNewlines rest = rest
+
+handleParseError :: [LToken] -> ParseErrorBundle [LToken] Void -> String
+handleParseError toks bundle =
+ unlines
+ ( "Parse error(s) encountered:"
+ : map (formatError toks) (NE.toList (bundleErrors bundle))
+ )
+
+formatError :: [LToken] -> ParseError [LToken] Void -> String
+formatError toks err =
+ case err of
+ TrivialError offset unexpected expected ->
+ let unexpectedMsg =
+ case unexpected of
+ Nothing -> "unexpected end of input"
+ Just x -> "unexpected " ++ show x
+ expectedMsg =
+ if Set.null expected
+ then ""
+ else "; expected one of " ++ show (Set.toList expected)
+ in
+ "Parse error at token offset " ++ show offset ++ ": " ++ unexpectedMsg ++ expectedMsg
+ ++ "\nToken context:\n" ++ tokenContext toks offset
+
+ FancyError offset fancy ->
+ "Parse error at token offset " ++ show offset ++ ": " ++ show (Set.toList fancy)
+ ++ "\nToken context:\n" ++ tokenContext toks offset
+
+tokenContext :: [LToken] -> Int -> String
+tokenContext toks off =
+ let start = max 0 (off - 5)
+ end = min (length toks) (off + 6)
+ rows = zip [start ..] (take (end - start) (drop start toks))
+ in unlines (map render rows)
+ where
+ render (i, token)
+ | i == off = ">>> " ++ show i ++ ": " ++ show token
+ | otherwise = " " ++ show i ++ ": " ++ show token
diff --git a/src/Research.hs b/src/Research.hs
@@ -50,6 +50,7 @@ data LToken
| LStringLiteral String
| LIntegerLiteral Int
| LArrowLeft
+ | LArrowRight
| LNewline
deriving (Eq, Show, Ord)
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -122,6 +122,16 @@ lexer = testGroup "Lexer Tests"
expect = Right [LIdentifier "a", LArrowLeft, LIdentifier "b"]
runParser tricuLexer "" input @?= expect
+ , testCase "Lex |> as arrow-right token" $ do
+ let input = "f |> g"
+ expect = Right [LIdentifier "f", LArrowRight, LIdentifier "g"]
+ runParser tricuLexer "" input @?= expect
+
+ , testCase "Lex |> without surrounding spaces" $ do
+ let input = "a|>b"
+ expect = Right [LIdentifier "a", LArrowRight, LIdentifier "b"]
+ runParser tricuLexer "" input @?= expect
+
, testCase "Lex $ remains legal identifier char" $ do
let input = "foo$bar = 1"
expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1]
@@ -234,10 +244,10 @@ parser = testGroup "Parser Tests"
(SApp (SVar "g" Nothing) (SVar "y" Nothing))
parseSingle input @?= expect
- , testCase "Parse chained <| as right-associative" $ do
+ , testCase "Parse chained <| as left-associative" $ do
let input = "f <| g <| h"
- expect = SApp (SVar "f" Nothing)
- (SApp (SVar "g" Nothing) (SVar "h" Nothing))
+ expect = SApp (SApp (SVar "f" Nothing) (SVar "g" Nothing))
+ (SVar "h" Nothing)
parseSingle input @?= expect
, testCase "Parse <| after newline inside parens" $ do
@@ -251,6 +261,63 @@ parser = testGroup "Parser Tests"
expect = SLambda ["x"] (SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
(SVar "g" Nothing))
parseSingle input @?= expect
+
+ , testCase "Parse |> as low-precedence application" $ do
+ let input = "f x |> g y"
+ expect = SApp (SApp (SVar "g" Nothing) (SVar "y" Nothing))
+ (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+ parseSingle input @?= expect
+
+ , testCase "Parse chained |> as left-associative" $ do
+ let input = "f |> g |> h"
+ expect = SApp (SVar "h" Nothing)
+ (SApp (SVar "g" Nothing) (SVar "f" Nothing))
+ parseSingle input @?= expect
+
+ , testCase "Parse |> after newline inside parens" $ do
+ let input = "(f x |>\n g y)"
+ expect = SApp (SApp (SVar "g" Nothing) (SVar "y" Nothing))
+ (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+ parseSingle input @?= expect
+
+ , testCase "Parse |> in lambda body" $ do
+ let input = "(x : f x |> g)"
+ expect = SLambda ["x"] (SApp (SVar "g" Nothing)
+ (SApp (SVar "f" Nothing) (SVar "x" Nothing)))
+ parseSingle input @?= expect
+
+ , testCase "Parse mixed <| and |>" $ do
+ let input = "f |> g <| h"
+ expect = SApp (SApp (SVar "g" Nothing) (SVar "f" Nothing))
+ (SVar "h" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Parse forward pipe chain" $ do
+ let input = "x |> f |> g"
+ expect = SApp (SVar "g" Nothing)
+ (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+ parseSingle input @?= expect
+
+ , testCase "Parse backward pipe" $ do
+ let input = "f <| x"
+ expect = SApp (SVar "f" Nothing) (SVar "x" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Parse backward pipe chain left associative" $ do
+ let input = "f <| x <| y"
+ expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+ (SVar "y" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Parse newline after forward pipe" $ do
+ let input = "x |>\nf"
+ expect = SApp (SVar "f" Nothing) (SVar "x" Nothing)
+ parseSingle input @?= expect
+
+ , testCase "Parse newline after backward pipe" $ do
+ let input = "f <|\nx"
+ expect = SApp (SVar "f" Nothing) (SVar "x" Nothing)
+ parseSingle input @?= expect
]
simpleEvaluation :: TestTree
@@ -1835,11 +1902,14 @@ ioDriverTests = testGroup "IO driver tests"
]
final @?= ioOkResult (ofBytes (BS.pack [0, 255, 128, 1]))
- , testCase "stress test: many sleeping tasks complete promptly" $ do
- let n = 100
- build 0 = "pure \"done\""
- build k = "bind (fork (bind (sleep 1) (_ : pure \"x\"))) (h : bind (await h) (_ : " ++ build (k - 1) ++ "))"
- (final, _) <- runIOSourceWith unsafePerms Leaf Leaf ("main = io (" ++ build n ++ ")")
+ , testCase "stress test: many concurrent sleepers complete promptly" $ do
+ let n = 5000
+ (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
+ unlines
+ [ "spawner = y (self n acc : if (equal? n 0) (pure acc) (bind (fork (sleep 1)) (h : self (pred n) (pair h acc))))"
+ , "awaitAll = y (self hs : matchList (pure \"done\") (h r : bind (await h) (_ : self r)) hs)"
+ , "main = io (bind (spawner " ++ show n ++ " t) (hs : awaitAll hs))"
+ ]
final @?= ofString "done"
, testCase "long fork await loop does not leak" $ do
