Sane parser rewrite
This commit is contained in:
@@ -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 :
|
||||
|
||||
@@ -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 "")
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
665
src/Parser.hs
665
src/Parser.hs
@@ -4,347 +4,426 @@ import Lexer
|
||||
import Research
|
||||
|
||||
import Control.Monad (void)
|
||||
import Control.Monad.State
|
||||
import Data.List.NonEmpty (toList)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
|
||||
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))
|
||||
| name `Set.member` reservedNames ->
|
||||
fail ("reserved name cannot be used as identifier: " ++ name)
|
||||
| otherwise ->
|
||||
fail "Unexpected token while parsing integer literal"
|
||||
pure name
|
||||
_ -> fail "internal parser error: expected identifier"
|
||||
where
|
||||
isIdentifier (LIdentifier _) = True
|
||||
isIdentifier _ = False
|
||||
|
||||
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"
|
||||
tok :: (LToken -> Bool) -> String -> TokParser LToken
|
||||
tok predicate expected = satisfy predicate <?> expected
|
||||
|
||||
getIdentifier :: LToken -> String
|
||||
getIdentifier (LIdentifier name) = name
|
||||
getIdentifier _ = errorWithoutStackTrace "Expected identifier"
|
||||
peekP :: TokParser (Maybe LToken)
|
||||
peekP = do
|
||||
toks <- getInput
|
||||
pure $ case toks of
|
||||
[] -> Nothing
|
||||
x : _ -> Just x
|
||||
|
||||
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)
|
||||
atEndP :: TokParser Bool
|
||||
atEndP = null <$> getInput
|
||||
|
||||
formatError :: ParseError [LToken] Void -> String
|
||||
formatError (TrivialError offset msgUnexpected expected) =
|
||||
let unexpectedMsg = case msgUnexpected of
|
||||
Just x -> "unexpected token " ++ show x
|
||||
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"
|
||||
expectedMsg = if null expected
|
||||
Just x -> "unexpected " ++ show x
|
||||
expectedMsg =
|
||||
if Set.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"
|
||||
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
|
||||
|
||||
@@ -50,6 +50,7 @@ data LToken
|
||||
| LStringLiteral String
|
||||
| LIntegerLiteral Int
|
||||
| LArrowLeft
|
||||
| LArrowRight
|
||||
| LNewline
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
|
||||
86
test/Spec.hs
86
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
|
||||
|
||||
Reference in New Issue
Block a user