Sane parser rewrite

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 :

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 
+main = io <|
-  (putStrLn (append "Hello, " "tricu"))
+  bind (putStrLn (append "Hello, " "tricu"))
-  (_ : pure ""))
+  (_ : pure "")

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

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
 

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
+type TokParser = Parsec Void [LToken]
-  { parenDepth  :: Int
-  , bracketDepth :: Int
-  } deriving (Show)
 
-type ParserM = StateT PState (Parsec Void [LToken])
+data Context = Top | Nested
+  deriving (Eq, Show)
 
-satisfyM :: (LToken -> Bool) -> ParserM LToken
+reservedNames :: Set.Set String
-satisfyM f = do
+reservedNames = Set.fromList ["t", "!result"]
-  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)
 
 parseTricu :: String -> [TricuAST]
 parseTricu input =
-  case lexTricu input of
+  let toks = lexTricu input
-    [] -> []
+  in case runParser programP "" toks of
-    toks ->
+       Left err   -> errorWithoutStackTrace (handleParseError toks err)
-      case parseProgram toks of
-        Left err   -> errorWithoutStackTrace (handleParseError err)
        Right asts -> asts
 
 parseSingle :: String -> TricuAST
 parseSingle input =
-  case lexTricu input of
+  let toks = lexTricu input
-    [] -> SEmpty
+  in case parseSingleExpr toks of
-    toks ->
+       Left err  -> errorWithoutStackTrace (handleParseError toks err)
-      case parseSingleExpr toks of
-        Left err -> errorWithoutStackTrace (handleParseError err)
        Right ast -> ast
 
-parseProgramM :: ParserM [TricuAST]
+parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST]
-parseProgramM = do
+parseProgram = runParser programP ""
-  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
+parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST
-parseImportM = do
+parseSingleExpr = runParser singleP ""
-  LImport filePath moduleName <- satisfyM isImport
+
-  pure (SImport filePath moduleName)
+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
+exprTopP :: TokParser TricuAST
-parseOneExpression = scnParserM *> parseExpressionM
+exprTopP = do
+  toks <- getInput
+  case lambdaHeadTop toks of
+    Just params -> lambdaP Top params
+    Nothing     -> pipeTopP
 
-scnParserM :: ParserM ()
+exprNestedP :: TokParser TricuAST
-scnParserM = skipMany $ do
+exprNestedP = do
-  t  <- lookAhead anySingle
+  skipNestedNewlines
-  st <- get
+  toks <- getInput
-  if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
+  case lambdaHeadNested toks of
-       void $ satisfyM (== LNewline)
+    Just params -> lambdaP Nested params
-     | otherwise ->
+    Nothing     -> pipeNestedP
-       fail "In nested context or no space token" <|> empty
 
-eofM :: ParserM ()
+lambdaP :: Context -> [String] -> TokParser TricuAST
-eofM = lift eof
+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
+lambdaHeadTop :: [LToken] -> Maybe [String]
-parseExpressionM = choice
+lambdaHeadTop toks =
-  [ try parseFunctionM
+  case collectIdentifiersNoNewlines toks of
-  , try parseLambdaM
+    (params@(_:_), LColon : _) -> Just params
-  , try parseLambdaExpressionM
+    _                          -> Nothing
-  , try parseListLiteralM
-  , try parseTreeTermM
-  , try parseArrowLeftM
-  , parseLiteralM
-  ]
 
-parseFunctionM :: ParserM TricuAST
+lambdaHeadNested :: [LToken] -> Maybe [String]
-parseFunctionM = do
+lambdaHeadNested toks =
-  let ident = (\case LIdentifier _ -> True; _ -> False)
+  case collectIdentifiersWithNewlines (dropNewlines toks) of
-  LIdentifier name <- satisfyM ident
+    (params@(_:_), rest) ->
-  args <- many $ satisfyM ident
+      case dropNewlines rest of
-  _    <- satisfyM (== LAssign)
+        LColon : _ -> Just params
-  scnParserM
+        _          -> Nothing
-  body <- parseExpressionM
+    _ -> Nothing
-  pure (SDef name (map getIdentifier args) body)
 
-parseLambdaM :: ParserM TricuAST
+collectIdentifiersNoNewlines :: [LToken] -> ([String], [LToken])
-parseLambdaM = do
+collectIdentifiersNoNewlines (LIdentifier name : rest) =
-  let ident = (\case LIdentifier _ -> True; _ -> False)
+  let (names, final) = collectIdentifiersNoNewlines rest
-  params <- some (satisfyM ident)
+  in (name : names, final)
-  _      <- satisfyM (== LColon)
+collectIdentifiersNoNewlines rest = ([], rest)
-  scnParserM
-  body  <- parseLambdaExpressionM
-  pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
 
-parseLambdaExpressionM :: ParserM TricuAST
+collectIdentifiersWithNewlines :: [LToken] -> ([String], [LToken])
-parseLambdaExpressionM = choice
+collectIdentifiersWithNewlines (LIdentifier name : rest) =
-  [ try parseLambdaArrowLeftM
+  let (names, final) = collectIdentifiersWithNewlines (dropNewlines rest)
-  , parseAtomicLambdaM
+  in (name : names, final)
-  ]
+collectIdentifiersWithNewlines rest = ([], rest)
 
-parseAtomicLambdaM :: ParserM TricuAST
+consumeLambdaHead :: Context -> [String] -> TokParser ()
-parseAtomicLambdaM = choice
+consumeLambdaHead ctx params = do
-  [ try parseLambdaM
+  case ctx of
-  , parseVarM
+    Top    -> pure ()
-  , parseTreeLeafM
+    Nested -> skipNestedNewlines
-  , parseLiteralM
-  , parseListLiteralM
-  , between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
-  ]
 
-parseApplicationM :: ParserM TricuAST
+  mapM_ consumeParam params
-parseApplicationM = do
-  func <- parseAtomicBaseM
-  scnParserM
-  args <- many $ do
-    scnParserM
-    arg <- parseAtomicM
-    return arg
-  return $ foldl SApp func args
 
-parseLambdaApplicationM :: ParserM TricuAST
+  case ctx of
-parseLambdaApplicationM = do
+    Top    -> pure ()
-  func <- parseAtomicLambdaM
+    Nested -> skipNestedNewlines
-  scnParserM
-  args <- many $ do
-    arg <- parseAtomicLambdaM
-    scnParserM
-    pure arg
-  pure $ foldl SApp func args
 
-parseArrowLeftM :: ParserM TricuAST
+  void (tok (== LColon) ":")
-parseArrowLeftM = do
+  skipNestedNewlines
-  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)
   where
-    combine acc next
+    consumeParam _ = do
-      | TLeaf     <- acc = TStem next
+      void identifierNameP
-      | TStem t   <- acc = TFork t next
+      case ctx of
-      | TFork _ _ <- acc = TFork acc next
+        Top    -> pure ()
-      | otherwise        = SApp acc next
+        Nested -> skipNestedNewlines
 
-parseTreeLeafOrParenthesizedM :: ParserM TricuAST
+data PipeOp = PipeBackward | PipeForward
-parseTreeLeafOrParenthesizedM = choice
+  deriving (Eq, Show)
-  [ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM
-  , parseTreeLeafM
-  ]
 
-parseAtomicM :: ParserM TricuAST
+applyPipe :: TricuAST -> (PipeOp, TricuAST) -> TricuAST
-parseAtomicM = choice
+applyPipe acc (PipeBackward, rhs) =
-  [ try parseLambdaM
+  SApp acc rhs
-  , parseVarM
-  , parseTreeLeafM
-  , parseListLiteralM
-  , parseGroupedM
-  , parseLiteralM
-  ]
 
-parseGroupedM :: ParserM TricuAST
+applyPipe acc (PipeForward, rhs) =
-parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $
+  SApp rhs acc
-  scnParserM *> parseExpressionM <* scnParserM
 
-parseLiteralM :: ParserM TricuAST
+pipeTopP :: TokParser TricuAST
-parseLiteralM = choice
+pipeTopP =
-  [ parseIntLiteralM
+  pipeChainP appTopP appNestedP
-  , parseStrLiteralM
-  ]
 
-parseListLiteralM :: ParserM TricuAST
+pipeNestedP :: TokParser TricuAST
-parseListLiteralM = do
+pipeNestedP =
-  _        <- satisfyM (== LOpenBracket)
+  pipeChainP appNestedP appNestedP
-  elements <- many $ do
-    scnParserM
-    parseListItemM
-  scnParserM
-  _        <- satisfyM (== LCloseBracket)
-  pure (SList elements)
 
-parseListItemM :: ParserM TricuAST
+pipeChainP :: TokParser TricuAST -> TokParser TricuAST -> TokParser TricuAST
-parseListItemM = choice
+pipeChainP parseFirst parseOperand = do
-  [ parseGroupedItemM
+  first <- parseFirst
-  , parseListLiteralM
+  rest <- many (try pipeSegmentP)
-  , parseSingleItemM
+  pure (foldl applyPipe first rest)
-  ]
+  where
+    pipeSegmentP = do
+      skipNestedNewlines
+      op <- pipeOpP
+      skipNestedNewlines
+      rhs <- parseOperand
+      pure (op, rhs)
 
-parseGroupedItemM :: ParserM TricuAST
+pipeOpP :: TokParser PipeOp
-parseGroupedItemM = do
+pipeOpP =
-  _     <- satisfyM (== LOpenParen)
+      (tok (== LArrowLeft)  "<|" *> pure PipeBackward)
-  inner <- parseExpressionM
+  <|> (tok (== LArrowRight) "|>" *> pure PipeForward)
-  _     <- satisfyM (== LCloseParen)
-  pure inner
 
-parseSingleItemM :: ParserM TricuAST
+appTopP :: TokParser TricuAST
-parseSingleItemM = do
+appTopP = do
-  tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
+  first <- atomTopP
-  if | LIdentifier name <- tok -> pure (SVar name Nothing)
+  appRestTopP first
-     | tok == LKeywordT        -> pure TLeaf
-     | otherwise                 -> fail "Unexpected token in list item"
 
-parseVarM :: ParserM TricuAST
+appRestTopP :: TricuAST -> TokParser TricuAST
-parseVarM = do
+appRestTopP acc = do
-  tok <- satisfyM (\case
+  mt <- peekP
-    LNamespace _ -> True
+  case mt of
-    LIdentifier _ -> True
+    Just t | startsAtom t -> do
-    LIdentifierWithHash _ _ -> True
+      arg <- atomTopP
-    _ -> False)
+      appRestTopP (SApp acc arg)
+    _ -> pure acc
 
-  case tok of
+appNestedP :: TokParser TricuAST
-    LNamespace ns -> do
+appNestedP = do
-      _ <- satisfyM (== LDot)
+  first <- atomNestedP
-      LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
+  appRestNestedP first
-      pure $ SVar (ns ++ "." ++ name) Nothing
 
+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" ->
+      | name `Set.member` reservedNames ->
-        fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
+          fail ("reserved name cannot be used as identifier: " ++ name)
-      | 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"
+          pure name
+    _ -> fail "internal parser error: expected identifier"
+  where
+    isIdentifier (LIdentifier _) = True
+    isIdentifier _               = False
 
-parseStrLiteralM :: ParserM TricuAST
+tok :: (LToken -> Bool) -> String -> TokParser LToken
-parseStrLiteralM = do
+tok predicate expected = satisfy predicate <?> expected
-  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
+peekP :: TokParser (Maybe LToken)
-getIdentifier (LIdentifier name) = name
+peekP = do
-getIdentifier _                  = errorWithoutStackTrace "Expected identifier"
+  toks <- getInput
+  pure $ case toks of
+    []    -> Nothing
+    x : _ -> Just x
 
-handleParseError :: ParseErrorBundle [LToken] Void -> String
+atEndP :: TokParser Bool
-handleParseError bundle =
+atEndP = null <$> getInput
-  let errors = bundleErrors bundle
-      formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
-  in unlines ("Parse error(s) encountered:" : formattedErrors)
 
-formatError :: ParseError [LToken] Void -> String
+skipTopNewlines :: TokParser ()
-formatError (TrivialError offset msgUnexpected expected) =
+skipTopNewlines = skipMany (tok (== LNewline) "newline")
-  let unexpectedMsg = case msgUnexpected of
+
-        Just x  -> "unexpected token " ++ show x
+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)
+              else "; expected one of " ++ show (Set.toList expected)
-  in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++
+      in
-     if null expectedMsg then "" else " " ++ expectedMsg
+        "Parse error at token offset " ++ show offset ++ ": " ++ unexpectedMsg ++ expectedMsg
-formatError (FancyError offset _) =
+        ++ "\nToken context:\n" ++ tokenContext toks offset
-  "Parse error at offset " ++ show offset ++ ": unexpected FancyError"
+
+    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

src/Research.hs

@@ -50,6 +50,7 @@ data LToken
   | LStringLiteral String
   | LIntegerLiteral Int
   | LArrowLeft
+  | LArrowRight
   | LNewline
   deriving (Eq, Show, Ord)
 

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)
+          expect = SApp (SApp (SVar "f" Nothing) (SVar "g" Nothing))
-                        (SApp (SVar "g" Nothing) (SVar "h" 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
+  , testCase "stress test: many concurrent sleepers complete promptly" $ do
-      let n = 100
+      let n = 5000
-          build 0 = "pure \"done\""
+      (final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
-          build k = "bind (fork (bind (sleep 1) (_ : pure \"x\"))) (h : bind (await h) (_ : " ++ build (k - 1) ++ "))"
+        unlines
-      (final, _) <- runIOSourceWith unsafePerms Leaf Leaf ("main = io (" ++ build n ++ ")")
+          [ "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