From e3dcf5edd713f236e37bd1d736905ac57b257129 Mon Sep 17 00:00:00 2001 From: James Eversole Date: Wed, 13 May 2026 19:39:15 -0500 Subject: [PATCH] Update demos and adds <| --- demos/interactionTrees.tri | 58 +++++++++++ demos/interactionTrees/environment.tri | 20 ++++ demos/interactionTrees/forkAwait.tri | 18 ++++ demos/interactionTrees/greet.tri | 10 ++ demos/interactionTrees/safeRead.tri | 16 ++++ demos/interactionTrees/shout.tri | 23 +++++ demos/interactionTrees/state.tri | 22 +++++ demos/interactionTrees/writeThenRead.tri | 20 ++++ demos/interactionTrees/yield.tri | 33 +++++++ demos/monadicIO.tri | 86 ----------------- src/Lexer.hs | 4 + src/Parser.hs | 32 ++++++- src/Research.hs | 1 + test/Spec.hs | 117 +++++++++++++++-------- 14 files changed, 333 insertions(+), 127 deletions(-) create mode 100644 demos/interactionTrees.tri create mode 100644 demos/interactionTrees/environment.tri create mode 100644 demos/interactionTrees/forkAwait.tri create mode 100644 demos/interactionTrees/greet.tri create mode 100644 demos/interactionTrees/safeRead.tri create mode 100644 demos/interactionTrees/shout.tri create mode 100644 demos/interactionTrees/state.tri create mode 100644 demos/interactionTrees/writeThenRead.tri create mode 100644 demos/interactionTrees/yield.tri delete mode 100644 demos/monadicIO.tri diff --git a/demos/interactionTrees.tri b/demos/interactionTrees.tri new file mode 100644 index 0000000..14d5c5f --- /dev/null +++ b/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 diff --git a/demos/interactionTrees/environment.tri b/demos/interactionTrees/environment.tri new file mode 100644 index 0000000..543d4d0 --- /dev/null +++ b/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)) diff --git a/demos/interactionTrees/forkAwait.tri b/demos/interactionTrees/forkAwait.tri new file mode 100644 index 0000000..8034c4d --- /dev/null +++ b/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)))))))) diff --git a/demos/interactionTrees/greet.tri b/demos/interactionTrees/greet.tri new file mode 100644 index 0000000..1d4e4ee --- /dev/null +++ b/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 "")) diff --git a/demos/interactionTrees/safeRead.tri b/demos/interactionTrees/safeRead.tri new file mode 100644 index 0000000..b70efe8 --- /dev/null +++ b/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") diff --git a/demos/interactionTrees/shout.tri b/demos/interactionTrees/shout.tri new file mode 100644 index 0000000..8ca9481 --- /dev/null +++ b/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)) diff --git a/demos/interactionTrees/state.tri b/demos/interactionTrees/state.tri new file mode 100644 index 0000000..f986241 --- /dev/null +++ b/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))))))))) diff --git a/demos/interactionTrees/writeThenRead.tri b/demos/interactionTrees/writeThenRead.tri new file mode 100644 index 0000000..84f6d63 --- /dev/null +++ b/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)) diff --git a/demos/interactionTrees/yield.tri b/demos/interactionTrees/yield.tri new file mode 100644 index 0000000..0f55a55 --- /dev/null +++ b/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)))))))) diff --git a/demos/monadicIO.tri b/demos/monadicIO.tri deleted file mode 100644 index 47c4fcd..0000000 --- a/demos/monadicIO.tri +++ /dev/null @@ -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 diff --git a/src/Lexer.hs b/src/Lexer.hs index 0b7f74a..8af95fb 100644 --- a/src/Lexer.hs +++ b/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 diff --git a/src/Parser.hs b/src/Parser.hs index 52adc48..0a03b25 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -112,8 +112,8 @@ parseExpressionM = choice , try parseLambdaM , try parseLambdaExpressionM , try parseListLiteralM - , try parseApplicationM , try parseTreeTermM + , try parseArrowLeftM , parseLiteralM ] @@ -138,7 +138,7 @@ parseLambdaM = do parseLambdaExpressionM :: ParserM TricuAST parseLambdaExpressionM = choice - [ try parseLambdaApplicationM + [ try parseLambdaArrowLeftM , parseAtomicLambdaM ] @@ -172,6 +172,34 @@ parseLambdaApplicationM = do pure arg pure $ foldl SApp func args +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 diff --git a/src/Research.hs b/src/Research.hs index 35633b1..e86007c 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -49,6 +49,7 @@ data LToken | LCloseBracket | LStringLiteral String | LIntegerLiteral Int + | LArrowLeft | LNewline deriving (Eq, Show, Ord) diff --git a/test/Spec.hs b/test/Spec.hs index 0f5d59d..5e7345e 100644 --- a/test/Spec.hs +++ b/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 @@ -1571,32 +1610,32 @@ ioDriverTests = testGroup "IO driver tests" ] final @?= Fork (ofString "root-local") (ofString "root") - , testCase "local does not affect outer bind continuation" $ do - final <- runIOSourceWithEnv unsafePerms (ofString "root") $ - unlines - [ "main = io (bind" - , " (local (env : append env \"-local\") (pure \"x\"))" - , " (_ : bind ask (env : pure env)))" - ] - final @?= ofString "root" + , testCase "local does not affect outer bind continuation" $ do + final <- runIOSourceWithEnv unsafePerms (ofString "root") $ + unlines + [ "main = io (bind" + , " (local (env : append env \"-local\") (pure \"x\"))" + , " (_ : bind ask (env : pure env)))" + ] + final @?= ofString "root" - , testCase "local environment persists across inner binds" $ do - final <- runIOSourceWithEnv unsafePerms (ofString "root") $ - unlines - [ "main = io (local (env : append env \"-local\")" - , " (bind (pure t) (_ :" - , " bind ask (env : pure env))))" - ] - final @?= ofString "root-local" + , testCase "local environment persists across inner binds" $ do + final <- runIOSourceWithEnv unsafePerms (ofString "root") $ + unlines + [ "main = io (local (env : append env \"-local\")" + , " (bind (pure t) (_ :" + , " bind ask (env : pure env))))" + ] + final @?= ofString "root-local" - , testCase "local restores environment when scoped action returns error value" $ do - final <- runIOSourceWithEnv defaultPerms (ofString "root") $ - unlines - [ "main = io (bind" - , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))" - , " (_ : bind ask (env : pure env)))" - ] - final @?= ofString "root" + , testCase "local restores environment when scoped action returns error value" $ do + final <- runIOSourceWithEnv defaultPerms (ofString "root") $ + unlines + [ "main = io (bind" + , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))" + , " (_ : bind ask (env : pure env)))" + ] + final @?= ofString "root" -- State tests , testCase "get returns initial state" $ do @@ -1745,22 +1784,22 @@ ioDriverTests = testGroup "IO driver tests" ] final @?= ofString "awake" - , testCase "await waits for sleeping child and returns child value" $ do - (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ - unlines - [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :" - , " await h))" - ] - final @?= ofString "child done" - st @?= Leaf + , testCase "await waits for sleeping child and returns child value" $ do + (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ + unlines + [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :" + , " await h))" + ] + final @?= ofString "child done" + st @?= Leaf - , testCase "sleep inside bind resumes as unit" $ do - (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ - unlines - [ "main = io (bind (sleep 1) (_ : pure \"awake\"))" - ] - final @?= ofString "awake" - st @?= Leaf + , testCase "sleep inside bind resumes as unit" $ do + (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ + unlines + [ "main = io (bind (sleep 1) (_ : pure \"awake\"))" + ] + final @?= ofString "awake" + st @?= Leaf , testCase "fork await returns child value" $ do (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $