diff --git a/demos/interactionTrees/forkAwait.tri b/demos/interactionTrees/forkAwait.tri index 8034c4d..4be6a8e 100644 --- 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 index 1d4e4ee..09dd002 100644 --- 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 index 550b9f6..5205acb 100644 --- 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 index 8af95fb..c3ad9c4 100644 --- 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 index 0a03b25..a574d21 100644 --- 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 TokParser = Parsec Void [LToken] -type ParserM = StateT PState (Parsec Void [LToken]) +data Context = Top | Nested + deriving (Eq, Show) -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)" - -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 - -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 + let toks = lexTricu input + in case parseSingleExpr toks of + Left err -> errorWithoutStackTrace (handleParseError toks 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) +parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST] +parseProgram = runParser programP "" -parseImportM :: ParserM TricuAST -parseImportM = do - LImport filePath moduleName <- satisfyM isImport - pure (SImport filePath moduleName) +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 +exprTopP :: TokParser TricuAST +exprTopP = do + toks <- getInput + case lambdaHeadTop toks of + Just params -> lambdaP Top params + Nothing -> pipeTopP -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 +exprNestedP :: TokParser TricuAST +exprNestedP = do + skipNestedNewlines + toks <- getInput + case lambdaHeadNested toks of + Just params -> lambdaP Nested params + Nothing -> pipeNestedP -eofM :: ParserM () -eofM = lift eof +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) -parseExpressionM :: ParserM TricuAST -parseExpressionM = choice - [ try parseFunctionM - , try parseLambdaM - , try parseLambdaExpressionM - , try parseListLiteralM - , try parseTreeTermM - , try parseArrowLeftM - , parseLiteralM - ] +lambdaHeadTop :: [LToken] -> Maybe [String] +lambdaHeadTop toks = + case collectIdentifiersNoNewlines toks of + (params@(_:_), LColon : _) -> Just params + _ -> Nothing -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) +lambdaHeadNested :: [LToken] -> Maybe [String] +lambdaHeadNested toks = + case collectIdentifiersWithNewlines (dropNewlines toks) of + (params@(_:_), rest) -> + case dropNewlines rest of + LColon : _ -> Just params + _ -> Nothing + _ -> Nothing -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 +collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken]) +collectIdentifiersNoNewlines (LIdentifier name : rest) = + let (names, final) = collectIdentifiersNoNewlines rest + in (name : names, final) +collectIdentifiersNoNewlines rest = ([], rest) -parseLambdaExpressionM :: ParserM TricuAST -parseLambdaExpressionM = choice - [ try parseLambdaArrowLeftM - , parseAtomicLambdaM - ] +collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken]) +collectIdentifiersWithNewlines (LIdentifier name : rest) = + let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest) + in (name : names, final) +collectIdentifiersWithNewlines rest = ([], rest) -parseAtomicLambdaM :: ParserM TricuAST -parseAtomicLambdaM = choice - [ try parseLambdaM - , parseVarM - , parseTreeLeafM - , parseLiteralM - , parseListLiteralM - , between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM - ] +consumeLambdaHead :: Context -> [String] -> TokParser () +consumeLambdaHead ctx params = do + case ctx of + Top -> pure () + Nested -> skipNestedNewlines -parseApplicationM :: ParserM TricuAST -parseApplicationM = do - func <- parseAtomicBaseM - scnParserM - args <- many $ do - scnParserM - arg <- parseAtomicM - return arg - return $ foldl SApp func args + mapM_ consumeParam params -parseLambdaApplicationM :: ParserM TricuAST -parseLambdaApplicationM = do - func <- parseAtomicLambdaM - scnParserM - args <- many $ do - arg <- parseAtomicLambdaM - scnParserM - pure arg - pure $ foldl SApp func args + case ctx of + Top -> pure () + Nested -> skipNestedNewlines -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) + 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 + consumeParam _ = do + void identifierNameP + case ctx of + Top -> pure () + Nested -> skipNestedNewlines -parseTreeLeafOrParenthesizedM :: ParserM TricuAST -parseTreeLeafOrParenthesizedM = choice - [ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM - , parseTreeLeafM - ] +data PipeOp = PipeBackward | PipeForward + deriving (Eq, Show) -parseAtomicM :: ParserM TricuAST -parseAtomicM = choice - [ try parseLambdaM - , parseVarM - , parseTreeLeafM - , parseListLiteralM - , parseGroupedM - , parseLiteralM - ] +applyPipe :: TricuAST -> (PipeOp, TricuAST) -> TricuAST +applyPipe acc (PipeBackward, rhs) = + SApp acc rhs -parseGroupedM :: ParserM TricuAST -parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ - scnParserM *> parseExpressionM <* scnParserM +applyPipe acc (PipeForward, rhs) = + SApp rhs acc -parseLiteralM :: ParserM TricuAST -parseLiteralM = choice - [ parseIntLiteralM - , parseStrLiteralM - ] +pipeTopP :: TokParser TricuAST +pipeTopP = + pipeChainP appTopP appNestedP -parseListLiteralM :: ParserM TricuAST -parseListLiteralM = do - _ <- satisfyM (== LOpenBracket) - elements <- many $ do - scnParserM - parseListItemM - scnParserM - _ <- satisfyM (== LCloseBracket) - pure (SList elements) +pipeNestedP :: TokParser TricuAST +pipeNestedP = + pipeChainP appNestedP appNestedP -parseListItemM :: ParserM TricuAST -parseListItemM = choice - [ parseGroupedItemM - , parseListLiteralM - , parseSingleItemM - ] +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) -parseGroupedItemM :: ParserM TricuAST -parseGroupedItemM = do - _ <- satisfyM (== LOpenParen) - inner <- parseExpressionM - _ <- satisfyM (== LCloseParen) - pure inner +pipeOpP :: TokParser PipeOp +pipeOpP = + (tok (== LArrowLeft) "<|" *> pure PipeBackward) + <|> (tok (== LArrowRight) "|>" *> pure PipeForward) -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" +appTopP :: TokParser TricuAST +appTopP = do + first <- atomTopP + appRestTopP first -parseVarM :: ParserM TricuAST -parseVarM = do - tok <- satisfyM (\case - LNamespace _ -> True - LIdentifier _ -> True - LIdentifierWithHash _ _ -> True - _ -> False) +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 - case tok of - LNamespace ns -> do - _ <- satisfyM (== LDot) - LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False) - pure $ SVar (ns ++ "." ++ name) Nothing +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) + | 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 - LIdentifierWithHash name hash -> - if name == "t" || name == "!result" - then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") - else pure (SVar name (Just hash)) +tok :: (LToken -> Bool) -> String -> TokParser LToken +tok predicate expected = satisfy predicate expected - _ -> fail "Unexpected token while parsing variable" +peekP :: TokParser (Maybe LToken) +peekP = do + toks <- getInput + pure $ case toks of + [] -> Nothing + x : _ -> Just x -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" +atEndP :: TokParser Bool +atEndP = null <$> getInput -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" +skipTopNewlines :: TokParser () +skipTopNewlines = skipMany (tok (== LNewline) "newline") -getIdentifier :: LToken -> String -getIdentifier (LIdentifier name) = name -getIdentifier _ = errorWithoutStackTrace "Expected identifier" +skipNestedNewlines :: TokParser () +skipNestedNewlines = skipMany (tok (== LNewline) "newline") -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) +dropNewlines :: [LToken] -> [LToken] +dropNewlines (LNewline : rest) = dropNewlines rest +dropNewlines rest = rest -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" +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 index e86007c..75de915 100644 --- 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 index c85d0dc..9d0631e 100644 --- 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