Sane parser rewrite

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