Update demos and adds <|

demos/interactionTrees.tri

@@ -0,0 +1,58 @@
+!import "../lib/base.tri"      !Local
+!import "../lib/list.tri"      !Local
+!import "../lib/io.tri"        !Local
+
+-- Interaction Tree Effect Runtime
+--
+-- The IO system is an interaction-tree effect runtime interpreted by a
+-- small-step machine with a cooperative scheduler.  Primitive actions
+-- (putStr, readFile, writeFile, ...) are tagged nodes in an interaction
+-- tree.  Sequencing is performed by the single generic `bind` constructor.
+--
+--   pure x            -- lift a pure value into IO
+--   bind action k     -- run action, then apply k to its result
+--   thenIO a b        -- run a, discard its result, then run b
+--   mapIO action f    -- run action, then apply f to its result inside pure
+--
+-- The runtime supports several effects beyond basic IO:
+--   ask               -- read the current environment
+--   local f action    -- run action with environment transformed by f
+--   get               -- read the current mutable state
+--   put s             -- replace the mutable state
+--   fork action       -- spawn a concurrent task, returning a handle
+--   await handle      -- wait for a forked task to complete
+--   yield             -- yield control to the scheduler
+--   sleep ms          -- suspend current task for N milliseconds
+--
+-- File operations return a Result tree (see lib/base.tri):
+--   ok value     -- pair true  (pair value t)
+--   err code     -- pair false (pair code  t)
+--
+-- Use onReadFile / onWriteFile for convenient branching.
+--
+-- See demos/interactionTrees/ for smaller focused examples.
+
+-- Cooperative async demo.
+--   fork runs an action in the background.
+--   sleep suspends the current task for N milliseconds.
+--   await waits for a forked task and returns its value.
+--
+--   Here the child sleeps for 2 s while the parent prints immediately.
+--   The parent's message appears first, proving interleaving.
+
+asyncDemo = (
+  bind (fork
+    (bind (sleep 2000) (_ :
+    bind (putStrLn "2000ms done sleeping!") (_ :
+    pure "child2000 done"))))
+  (handle2000 :
+  bind (fork
+    (bind (sleep 5000) (_ :
+    bind (putStrLn "5000ms done sleeping!") (_ :
+    pure "child5000 done"))))
+  (handle5000 :
+  bind (putStrLn "Parent first!") (_ :
+  bind (await handle5000) (_ :
+  await handle2000)))))
+
+main = io asyncDemo

demos/interactionTrees/environment.tri

@@ -0,0 +1,20 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Environment effects: ask and local.
+--   ask reads the current environment value.
+--   local f action runs action with the env transformed by f.
+--
+--   The CLI starts with an empty (Leaf) environment.  This demo uses
+--   local to inject a real string so that ask returns something readable.
+
+main = io <| 
+  (bind 
+  local (_ : "sandbox")
+    (bind ask (env :
+    bind (putStrLn (append "working in env: " env)) (_ :
+    pure "inside-done"))))
+  (outside :
+    bind (putStrLn (append "local returned: " outside)) (_ :
+    pure t))

demos/interactionTrees/forkAwait.tri

@@ -0,0 +1,18 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Basic fork and await.
+-- fork spawns a concurrent task and returns a handle.
+-- await blocks until the task completes and returns its value.
+
+worker = (msg :
+  bind (putStrLn (append "working: " msg)) (_ :
+  pure (append msg "-result")))
+
+main = io <|
+  (bind (fork (worker "job1")) (h1 :
+  bind (fork (worker "job2")) (h2 :
+  bind (await h1) (r1 :
+  bind (await h2) (r2 :
+  putStrLn (append "Got " (append r1 (append " and " r2))))))))

demos/interactionTrees/greet.tri

@@ -0,0 +1,10 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Greet and return a pure value.
+-- putStrLn writes to stdout; pure lifts "done" into IO.
+
+main = io (bind 
+  (putStrLn (append "Hello, " "tricu"))
+  (_ : pure ""))

demos/interactionTrees/safeRead.tri

@@ -0,0 +1,16 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- readFile returns a Result.  matchResult branches on ok / err.
+-- Run with --allow-read PATH or --unsafe-io.
+
+safeRead = (path :
+  bind (readFile path)
+    (result :
+      matchResult
+        (err rest : pure "ERROR: Unable to read file")
+        (contents rest : pure contents)
+        result))
+
+main = io (safeRead "demos/interactionTrees/greet.tri")

demos/interactionTrees/shout.tri

@@ -0,0 +1,23 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Transform an IO result.
+--   mapIO applies a pure function to the value produced by an action.
+--   Run with --allow-read PATH or --unsafe-io.
+
+safeRead = (path :
+  bind (readFile path)
+    (result :
+      matchResult
+        (err rest : pure "missing")
+        (contents rest : pure contents)
+        result))
+
+shout = (path :
+  mapIO (safeRead path)
+    (text : append text "!!!"))
+
+main = io (bind 
+    (shout "demos/interactionTrees/greet.tri")
+    (text : putStrLn text))

demos/interactionTrees/state.tri

@@ -0,0 +1,22 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Mutable state via get and put.
+--   get reads the current state.
+--   put replaces the state.
+--
+--   The CLI starts with an empty (Leaf) state.  This demo puts
+--   readable strings and prints them back out.
+
+main = io <|
+  bind (put "idle") (_ :
+  bind get (s1 :
+  bind (putStrLn (append "state: " s1)) (_ :
+  bind (put "running") (_ :
+  bind get (s2 :
+  bind (putStrLn (append "state: " s2)) (_ :
+  bind (put "done") (_ :
+  bind get (s3 :
+  bind (putStrLn (append "state: " s3)) (_ :
+  pure t)))))))))

demos/interactionTrees/writeThenRead.tri

@@ -0,0 +1,20 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Write a file, then read it back.
+--   thenIO discards the writeFile Result and continues.
+--   Run with --unsafe-io (needs both read and write permissions).
+
+writeThenRead = (path text :
+  thenIO
+    (writeFile path text)
+    (readFile path))
+
+main = io <|
+  (bind (writeThenRead "/tmp/tricu-demo.txt" "hello from tricu")
+    (result :
+      matchResult
+        (err rest : putStrLn "error")
+        (contents rest : putStrLn contents)
+        result))

demos/interactionTrees/yield.tri

@@ -0,0 +1,33 @@
+!import "../../lib/base.tri" !Local
+!import "../../lib/list.tri" !Local
+!import "../../lib/io.tri"   !Local
+
+-- Cooperative scheduling with yield.
+--   yield returns control to the scheduler so other tasks can run.
+--
+--   Two tasks print alternately because each yields after every line.
+
+--chatter = (name n :
+--  bind (putStrLn (append name " says 1")) (_ :
+--  bind yield (_ :
+--  bind (putStrLn (append name " says 2")) (_ :
+--  bind yield (_ :
+--  bind (putStrLn (append name " says 3")) (_ :
+--  pure n))))))
+
+chatter = name n : bind <|
+  putStrLn (append name " says 1") (_ :
+  bind yield (_ :
+  bind (putStrLn (append name " says 2")) (_ :
+  bind yield (_ :
+  bind (putStrLn (append name " says 3")) (_ :
+  pure n)))))
+
+
+main = io <|
+  bind (fork (chatter "A" "doneA")) (ha :
+  bind (fork (chatter "B" "doneB")) (hb :
+  bind yield (_ :
+  bind (await ha) (a :
+  bind (await hb) (b :
+  putStrLn (append "Finished: " (append a (append " " b))))))))

demos/monadicIO.tri

@@ -1,86 +0,0 @@
-!import "../lib/base.tri"      !Local
-!import "../lib/list.tri"      !Local
-!import "../lib/io.tri"        !Local
-
--- Monadic IO in tricu
---
--- The IO system is a free monad interpreted by the host.  Primitive actions
--- (putStr, readFile, writeFile, ...) do not carry their own continuations.
--- Sequencing is performed by the single generic `bind` constructor.
---
---   pure x            -- lift a pure value into IO
---   bind action k     -- run action, then apply k to its result
---   thenIO a b        -- run a, discard its result, then run b
---   mapIO action f    -- run action, then apply f to its result inside pure
---
--- File operations return a Result tree (see lib/base.tri):
---   ok value     -- pair true  (pair value t)
---   err code     -- pair false (pair code  t)
---
--- Use onReadFile / onWriteFile for convenient branching.
-
--- ----------------------------------------------------------------------------
--- Example 1: Greet and return a pure value.
---   putStrLn writes to stdout; pure lifts "done" into IO.
--- ----------------------------------------------------------------------------
-
-greet = (name :
-  bind (putStrLn (append "Hello, " name))
-    (_ : pure "done"))
-
--- ----------------------------------------------------------------------------
--- Example 2: Read a file safely.
---   readFile returns a Result.  matchResult branches on ok / err.
--- ----------------------------------------------------------------------------
-
-safeRead = (path :
-  bind (readFile path)
-    (result :
-      matchResult
-        (err rest : pure "missing")
-        (contents rest : pure contents)
-        result))
-
--- ----------------------------------------------------------------------------
--- Example 3: Write, then read back.
---   thenIO discards the writeFile Result and continues.
--- ----------------------------------------------------------------------------
-
-writeThenRead = (path text :
-  thenIO
-    (writeFile path text)
-    (readFile path))
-
--- ----------------------------------------------------------------------------
--- Example 4: Transform an IO result.
---   mapIO applies a pure function to the value produced by an action.
--- ----------------------------------------------------------------------------
-
-shout = (path :
-  mapIO (safeRead path)
-    (text : append text "!!!"))
-
--- ----------------------------------------------------------------------------
--- Example 5: Cooperative async.
---   fork runs an action in the background.
---   sleep suspends the current task for N milliseconds.
---   await waits for a forked task and returns its value.
---
---   Here the child sleeps for 2 s while the parent prints immediately.
---   The parent's message appears first, proving interleaving.
--- ----------------------------------------------------------------------------
-
-asyncDemo = (
-  bind (fork
-    (bind (sleep 2000) (_ :
-    bind (putStrLn "Done sleeping!") (_ :
-    pure "child done"))))
-  (handle :
-  bind (putStrLn "Parent first!") (_ :
-  await handle)))
-
--- ----------------------------------------------------------------------------
--- Main action - run the async demo.
--- ----------------------------------------------------------------------------
-
-main = io asyncDemo

src/Lexer.hs

@@ -45,6 +45,7 @@ tricuLexer = do
       , closeParen
       , openBracket
       , closeBracket
+      , try arrowLeft
       ]
 
 lexTricu :: String -> [LToken]
@@ -128,6 +129,9 @@ openBracket = char '[' $> LOpenBracket
 closeBracket :: Lexer LToken
 closeBracket = char ']' $> LCloseBracket
 
+arrowLeft :: Lexer LToken
+arrowLeft = string "<|" $> LArrowLeft
+
 lnewline :: Lexer LToken
 lnewline = char '\n' $> LNewline
 

src/Parser.hs

@@ -10,313 +10,3 @@ import Data.Void                 (Void)
 import Text.Megaparsec
 
 import qualified Data.Set as Set
-
-data PState = PState
-  { parenDepth  :: Int
-  , bracketDepth :: Int
-  } deriving (Show)
-
-type ParserM = StateT PState (Parsec Void [LToken])
-
-satisfyM :: (LToken -> Bool) -> ParserM LToken
-satisfyM f = do
-  tok <- lift (satisfy f)
-  modify' (updateDepth tok)
-  return tok
-
-updateDepth :: LToken -> PState -> PState
-updateDepth LOpenParen    st = st { parenDepth   = parenDepth st   + 1 }
-updateDepth LOpenBracket  st = st { bracketDepth = bracketDepth st + 1 }
-updateDepth LCloseParen   st = st { parenDepth   = parenDepth st   - 1 }
-updateDepth LCloseBracket st = st { bracketDepth = bracketDepth st - 1 }
-updateDepth _ st = st
-
-topLevelNewline :: ParserM ()
-topLevelNewline = do
-  st <- get
-  if parenDepth st == 0 && bracketDepth st == 0
-    then void (satisfyM (== LNewline))
-    else fail "Top-level exit in nested context (paren or bracket)"
-
-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
-    [] -> []
-    toks ->
-      case parseProgram toks of
-        Left err   -> errorWithoutStackTrace (handleParseError err)
-        Right asts -> asts
-
-parseSingle :: String -> TricuAST
-parseSingle input =
-  case lexTricu input of
-    [] -> SEmpty
-    toks ->
-      case parseSingleExpr toks of
-        Left err -> errorWithoutStackTrace (handleParseError err)
-        Right ast -> ast
-
-parseProgramM :: ParserM [TricuAST]
-parseProgramM = do
-  skipMany topLevelNewline
-  importNodes <- many (do
-    node <- parseImportM
-    skipMany topLevelNewline
-    return node)
-  skipMany topLevelNewline
-  exprs <- sepEndBy parseOneExpression (some topLevelNewline)
-  skipMany topLevelNewline
-  return (importNodes ++ exprs)
-
-parseImportM :: ParserM TricuAST
-parseImportM = do
-  LImport filePath moduleName <- satisfyM isImport
-  pure (SImport filePath moduleName)
-  where
-    isImport (LImport _ _) = True
-    isImport _             = False
-
-parseOneExpression :: ParserM TricuAST
-parseOneExpression = scnParserM *> parseExpressionM
-
-scnParserM :: ParserM ()
-scnParserM = skipMany $ do
-  t  <- lookAhead anySingle
-  st <- get
-  if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) ->
-       void $ satisfyM (== LNewline)
-     | otherwise ->
-       fail "In nested context or no space token" <|> empty
-
-eofM :: ParserM ()
-eofM = lift eof
-
-parseExpressionM :: ParserM TricuAST
-parseExpressionM = choice
-  [ try parseFunctionM
-  , try parseLambdaM
-  , try parseLambdaExpressionM
-  , try parseListLiteralM
-  , try parseApplicationM
-  , try parseTreeTermM
-  , parseLiteralM
-  ]
-
-parseFunctionM :: ParserM TricuAST
-parseFunctionM = do
-  let ident = (\case LIdentifier _ -> True; _ -> False)
-  LIdentifier name <- satisfyM ident
-  args <- many $ satisfyM ident
-  _    <- satisfyM (== LAssign)
-  scnParserM
-  body <- parseExpressionM
-  pure (SDef name (map getIdentifier args) body)
-
-parseLambdaM :: ParserM TricuAST
-parseLambdaM = do
-  let ident = (\case LIdentifier _ -> True; _ -> False)
-  params <- some (satisfyM ident)
-  _      <- satisfyM (== LColon)
-  scnParserM
-  body  <- parseLambdaExpressionM
-  pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params
-
-parseLambdaExpressionM :: ParserM TricuAST
-parseLambdaExpressionM = choice
-  [ try parseLambdaApplicationM
-  , parseAtomicLambdaM
-  ]
-
-parseAtomicLambdaM :: ParserM TricuAST
-parseAtomicLambdaM = choice
-  [ try parseLambdaM
-  , parseVarM
-  , parseTreeLeafM
-  , parseLiteralM
-  , parseListLiteralM
-  , between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM
-  ]
-
-parseApplicationM :: ParserM TricuAST
-parseApplicationM = do
-  func <- parseAtomicBaseM
-  scnParserM
-  args <- many $ do
-    scnParserM
-    arg <- parseAtomicM
-    return arg
-  return $ foldl SApp func args
-
-parseLambdaApplicationM :: ParserM TricuAST
-parseLambdaApplicationM = do
-  func <- parseAtomicLambdaM
-  scnParserM
-  args <- many $ do
-    arg <- parseAtomicLambdaM
-    scnParserM
-    pure arg
-  pure $ foldl SApp func args
-
-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
-      | TLeaf     <- acc = TStem next
-      | TStem t   <- acc = TFork t next
-      | TFork _ _ <- acc = TFork acc next
-      | otherwise        = SApp acc next
-
-parseTreeLeafOrParenthesizedM :: ParserM TricuAST
-parseTreeLeafOrParenthesizedM = choice
-  [ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM
-  , parseTreeLeafM
-  ]
-
-parseAtomicM :: ParserM TricuAST
-parseAtomicM = choice
-  [ try parseLambdaM
-  , parseVarM
-  , parseTreeLeafM
-  , parseListLiteralM
-  , parseGroupedM
-  , parseLiteralM
-  ]
-
-parseGroupedM :: ParserM TricuAST
-parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $
-  scnParserM *> parseExpressionM <* scnParserM
-
-parseLiteralM :: ParserM TricuAST
-parseLiteralM = choice
-  [ parseIntLiteralM
-  , parseStrLiteralM
-  ]
-
-parseListLiteralM :: ParserM TricuAST
-parseListLiteralM = do
-  _        <- satisfyM (== LOpenBracket)
-  elements <- many $ do
-    scnParserM
-    parseListItemM
-  scnParserM
-  _        <- satisfyM (== LCloseBracket)
-  pure (SList elements)
-
-parseListItemM :: ParserM TricuAST
-parseListItemM = choice
-  [ parseGroupedItemM
-  , parseListLiteralM
-  , parseSingleItemM
-  ]
-
-parseGroupedItemM :: ParserM TricuAST
-parseGroupedItemM = do
-  _     <- satisfyM (== LOpenParen)
-  inner <- parseExpressionM
-  _     <- satisfyM (== LCloseParen)
-  pure inner
-
-parseSingleItemM :: ParserM TricuAST
-parseSingleItemM = do
-  tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False)
-  if | LIdentifier name <- tok -> pure (SVar name Nothing)
-     | tok == LKeywordT        -> pure TLeaf
-     | otherwise                 -> fail "Unexpected token in list item"
-
-parseVarM :: ParserM TricuAST
-parseVarM = do
-  tok <- satisfyM (\case
-    LNamespace _ -> True
-    LIdentifier _ -> True
-    LIdentifierWithHash _ _ -> True
-    _ -> False)
-
-  case tok of
-    LNamespace ns -> do
-      _ <- satisfyM (== LDot)
-      LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False)
-      pure $ SVar (ns ++ "." ++ name) Nothing
-
-    LIdentifier name
-      | name == "t" || name == "!result" ->
-        fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
-      | otherwise -> pure (SVar name Nothing)
-
-    LIdentifierWithHash name hash ->
-      if name == "t" || name == "!result"
-        then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.")
-        else pure (SVar name (Just hash))
-
-    _ -> fail "Unexpected token while parsing variable"
-
-parseIntLiteralM :: ParserM TricuAST
-parseIntLiteralM = do
-  let intL = (\case LIntegerLiteral _ -> True; _ -> False)
-  tok <- satisfyM intL
-  if | LIntegerLiteral value <- tok ->
-       pure (SInt (fromIntegral value))
-     | otherwise                      ->
-       fail "Unexpected token while parsing integer literal"
-
-parseStrLiteralM :: ParserM TricuAST
-parseStrLiteralM = do
-  let strL = (\case LStringLiteral _ -> True; _ -> False)
-  tok <- satisfyM strL
-  if | LStringLiteral value <- tok ->
-       pure (SStr value)
-     | otherwise                     ->
-       fail "Unexpected token while parsing string literal"
-
-getIdentifier :: LToken -> String
-getIdentifier (LIdentifier name) = name
-getIdentifier _                  = errorWithoutStackTrace "Expected identifier"
-
-handleParseError :: ParseErrorBundle [LToken] Void -> String
-handleParseError bundle =
-  let errors = bundleErrors bundle
-      formattedErrors = map formatError (Data.List.NonEmpty.toList errors)
-  in unlines ("Parse error(s) encountered:" : formattedErrors)
-
-formatError :: ParseError [LToken] Void -> String
-formatError (TrivialError offset msgUnexpected expected) =
-  let unexpectedMsg = case msgUnexpected of
-        Just x  -> "unexpected token " ++ show x
-        Nothing -> "unexpected end of input"
-      expectedMsg = if null expected
-        then ""
-        else "expected " ++ show (Set.toList expected)
-  in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++
-     if null expectedMsg then "" else " " ++ expectedMsg
-formatError (FancyError offset _) =
-  "Parse error at offset " ++ show offset ++ ": unexpected FancyError"

src/Research.hs

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

test/Spec.hs

@@ -111,6 +111,21 @@ lexer = testGroup "Lexer Tests"
         case (runParser tricuLexer "" "!result = 5") of
           Left _ -> return ()
           Right _ -> assertFailure "Expected failure when trying to assign the value of !result"
+
+  , testCase "Lex <| as arrow-left token" $ do
+      let input = "f <| g"
+          expect = Right [LIdentifier "f", LArrowLeft, LIdentifier "g"]
+      runParser tricuLexer "" input @?= expect
+
+  , testCase "Lex <| without surrounding spaces" $ do
+      let input = "a<|b"
+          expect = Right [LIdentifier "a", LArrowLeft, 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]
+      runParser tricuLexer "" input @?= expect
   ]
 
 parser :: TestTree
@@ -212,6 +227,30 @@ parser = testGroup "Parser Tests"
       let input = "(t) -- (t) -- (t)"
           expect = [TLeaf]
       parseTricu input @?= expect
+
+  , testCase "Parse <| as low-precedence application" $ do
+      let input = "f x <| g y"
+          expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+                        (SApp (SVar "g" Nothing) (SVar "y" Nothing))
+      parseSingle input @?= expect
+
+  , testCase "Parse chained <| as right-associative" $ do
+      let input = "f <| g <| h"
+          expect = SApp (SVar "f" Nothing)
+                        (SApp (SVar "g" Nothing) (SVar "h" Nothing))
+      parseSingle input @?= expect
+
+  , testCase "Parse <| after newline inside parens" $ do
+      let input = "(f x <|\n  g y)"
+          expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+                        (SApp (SVar "g" Nothing) (SVar "y" Nothing))
+      parseSingle input @?= expect
+
+  , testCase "Parse <| in lambda body" $ do
+      let input = "(x : f x <| g)"
+          expect = SLambda ["x"] (SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing))
+                                      (SVar "g" Nothing))
+      parseSingle input @?= expect
   ]
 
 simpleEvaluation :: TestTree