CPS IO -> Async Interaction Tree Effect Runtime

I'm deeply satisfied to be building an interaction tree runtime where
the interaction trees are themselves computed via and represented by
trees. It's trees all the way down.
This commit is contained in:
2026-05-13 11:02:37 -05:00
parent 983a0cc5a7
commit 8f7684a1bb
6 changed files with 1965 additions and 117 deletions

View File

@@ -8,12 +8,13 @@ import REPL
import Research
import Wire
import ContentStore
import IODriver (IOPermissions(..), checkIOSentinel, runIO, unsafePerms)
import IODriver (IOPermissions(..), checkIOSentinel, runIO, runIOWithEnv, runIOWith, unsafePerms, defaultPerms)
import Control.Exception (evaluate, try, SomeException)
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import System.IO.Temp (withSystemTempDirectory)
import System.Directory (createDirectory)
import Data.Bits (xor)
import Data.Char (digitToInt)
import Data.List (isInfixOf)
@@ -1262,7 +1263,8 @@ byteListUtilities = testGroup "Byte List Utility Tests"
ioDriverTests :: TestTree
ioDriverTests = testGroup "IO driver tests"
[ testCase "readFile through onReadFile returns file contents" $
[ -- Existing behaviour tests
testCase "readFile through onReadFile returns file contents" $
withSystemTempDirectory "tricu-io-read" $ \dir -> do
let sourcePath = dir ++ "/input.txt"
writeFile sourcePath "abc123"
@@ -1300,13 +1302,496 @@ ioDriverTests = testGroup "IO driver tests"
, " (second rest : pure (append first second))))"
]
final @?= ofString "abcdef"
-- Monad law tests
, testCase "left identity: bind (pure x) f == f x" $ do
left <- runIOSource $
unlines
[ "f = x : pure (append x \"!\")"
, "main = io (bind (pure \"abc\") f)"
]
right <- runIOSource $
unlines
[ "f = x : pure (append x \"!\")"
, "main = io (f \"abc\")"
]
left @?= right
left @?= ofString "abc!"
, testCase "right identity: bind m pure == m" $
withSystemTempDirectory "tricu-io-right-id" $ \dir -> do
let path = dir ++ "/input.txt"
writeFile path "abc"
left <- runIOSource $
unlines
[ "main = io (bind (readFile \"" ++ path ++ "\")"
, " (result : pure result))"
]
right <- runIOSource $
unlines
[ "main = io (readFile \"" ++ path ++ "\")"
]
left @?= right
left @?= ioOkResult (ofString "abc")
, testCase "associativity: bind (bind m f) g == bind m (x : bind (f x) g)" $
withSystemTempDirectory "tricu-io-assoc" $ \dir -> do
let path = dir ++ "/input.txt"
writeFile path "abc"
left <- runIOSource $
unlines
[ "m = readFile \"" ++ path ++ "\""
, "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
, "g = value : pure (append value \"-g\")"
, "main = io (bind (bind m f) g)"
]
right <- runIOSource $
unlines
[ "m = readFile \"" ++ path ++ "\""
, "f = result : matchResult (err rest : pure \"read failed\") (contents rest : pure (append contents \"-f\")) result"
, "g = value : pure (append value \"-g\")"
, "main = io (bind m (x : bind (f x) g))"
]
left @?= right
left @?= ofString "abc-f-g"
, testCase "associativity preserves error flow" $
withSystemTempDirectory "tricu-io-assoc-err" $ \dir -> do
let missingPath = dir ++ "/missing.txt"
left <- runIOSource $
unlines
[ "m = readFile \"" ++ missingPath ++ "\""
, "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
, "g = value : pure (append value \"-g\")"
, "main = io (bind (bind m f) g)"
]
right <- runIOSource $
unlines
[ "m = readFile \"" ++ missingPath ++ "\""
, "f = result : matchResult (err rest : pure \"handled\") (contents rest : pure (append contents \"-ok\")) result"
, "g = value : pure (append value \"-g\")"
, "main = io (bind m (x : bind (f x) g))"
]
left @?= right
left @?= ofString "handled-g"
, testCase "bind defers continuation until left action completes" $
withSystemTempDirectory "tricu-io-lazy-k" $ \dir -> do
let path = dir ++ "/created.txt"
final <- runIOSource $
unlines
[ "main = io (bind (writeFile \"" ++ path ++ "\" \"created\")"
, " (_ : readFile \"" ++ path ++ "\"))"
]
final @?= ioOkResult (ofString "created")
-- Primitive effect shape tests
, testCase "readFile without continuation returns Result" $
withSystemTempDirectory "tricu-io-raw-read" $ \dir -> do
let path = dir ++ "/input.txt"
writeFile path "abc"
final <- runIOSource $
unlines
[ "main = io (readFile \"" ++ path ++ "\")"
]
final @?= ioOkResult (ofString "abc")
, testCase "writeFile then readFile executes exactly once" $
withSystemTempDirectory "tricu-io-once" $ \dir -> do
let path = dir ++ "/test.txt"
final <- runIOSource $
unlines
[ "main = io (bind (writeFile \"" ++ path ++ "\" \"abc\")"
, " (_ : readFile \"" ++ path ++ "\"))"
]
final @?= ioOkResult (ofString "abc")
, testCase "sequencing order is left-to-right" $
withSystemTempDirectory "tricu-io-order" $ \dir -> do
let path = dir ++ "/test.txt"
final <- runIOSource $
unlines
[ "main = io (bind (writeFile \"" ++ path ++ "\" \"a\")"
, " (_ : bind (writeFile \"" ++ path ++ "\" \"ab\")"
, " (_ : readFile \"" ++ path ++ "\")))"
]
final @?= ioOkResult (ofString "ab")
, testCase "thenIO sequences two actions and discards first result" $
withSystemTempDirectory "tricu-io-then" $ \dir -> do
let path = dir ++ "/test.txt"
final <- runIOSource $
unlines
[ "main = io (thenIO (writeFile \"" ++ path ++ "\" \"x\")"
, " (readFile \"" ++ path ++ "\"))"
]
final @?= ioOkResult (ofString "x")
, testCase "bind does not short-circuit on readFile error" $
withSystemTempDirectory "tricu-io-no-short" $ \dir -> do
let path = dir ++ "/missing.txt"
final <- runIOSource $
unlines
[ "main = io (bind (readFile \"" ++ path ++ "\")"
, " (result : pure \"continued\"))"
]
final @?= ofString "continued"
, testCase "mapIO transforms pure value" $ do
final <- runIOSource $
unlines
[ "main = io (mapIO (pure \"abc\") (x : append x \"!\"))"
]
final @?= ofString "abc!"
-- Malformed action tests
, testCase "unknown IO action tag returns err result" $ do
final <- runIOSource "main = io (pair 99 t)"
final @?= ioErrResult 40
, testCase "malformed Bind returns err result" $ do
final <- runIOSource "main = io (pair 1 t)"
final @?= ioErrResult 40
, testCase "malformed ReadFile payload returns err result" $ do
final <- runIOSource "main = io (readFile (t t))"
final @?= ioErrResult 41
-- Permission tests
, testCase "allowed read path succeeds" $
withSystemTempDirectory "tricu-io-allowed" $ \dir -> do
let path = dir ++ "/allowed.txt"
writeFile path "allowed"
let perms = defaultPerms { allowRead = [path] }
result <- runIOSourceWithPerms perms $
unlines
[ "main = io (readFile \"" ++ path ++ "\")"
]
result @?= ioOkResult (ofString "allowed")
, testCase "readFile denied path returns err result" $
withSystemTempDirectory "tricu-io-read-denied" $ \dir -> do
let allowedPath = dir ++ "/allowed.txt"
deniedPath = dir ++ "/denied.txt"
writeFile allowedPath "allowed"
writeFile deniedPath "denied"
let perms = defaultPerms { allowRead = [allowedPath] }
result <- runIOSourceWithPerms perms $
unlines
[ "main = io (readFile \"" ++ deniedPath ++ "\")"
]
result @?= ioErrResult 20
, testCase "writeFile denied path returns err result" $
withSystemTempDirectory "tricu-io-write-denied" $ \dir -> do
let allowedPath = dir ++ "/allowed.txt"
deniedPath = dir ++ "/denied.txt"
let perms = defaultPerms { allowWrite = [allowedPath] }
result <- runIOSourceWithPerms perms $
unlines
[ "main = io (writeFile \"" ++ deniedPath ++ "\" \"x\")"
]
result @?= ioErrResult 20
, testCase "path prefix does not allow prefix bypass" $
withSystemTempDirectory "tricu-io-prefix" $ \dir -> do
let allowedDir = dir ++ "/foo"
bypassPath = dir ++ "/foobar/secret.txt"
createDirectory allowedDir
createDirectory (dir ++ "/foobar")
writeFile bypassPath "secret"
let perms = defaultPerms { allowRead = [allowedDir] }
result <- runIOSourceWithPerms perms $
unlines
[ "main = io (readFile \"" ++ bypassPath ++ "\")"
]
result @?= ioErrResult 20
-- Pure test
, testCase "pure performs no effects" $ do
final <- runIOSource "main = io (pure \"abc\")"
final @?= ofString "abc"
-- Reader tests
, testCase "ask returns initial environment" $ do
final <- runIOSourceWithEnv unsafePerms (ofString "dev") $
unlines
[ "main = io (bind ask (env : pure env))"
]
final @?= ofString "dev"
, testCase "local transforms environment" $ do
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
unlines
[ "main = io (local (env : append env \"-local\") (bind ask (env : pure env)))"
]
final @?= ofString "root-local"
, testCase "local restores environment afterward" $ do
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
unlines
[ "main = io (bind ask (before :"
, " bind (local (env : append env \"-local\") (bind ask (env : pure env))) (inside :"
, " bind ask (after :"
, " pure (pair before (pair inside after))))))"
]
final @?= Fork (ofString "root") (Fork (ofString "root-local") (ofString "root"))
, testCase "nested local composes correctly" $ do
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
unlines
[ "f = x : append x \"-f\""
, "g = x : append x \"-g\""
, "main = io (bind"
, " (local f (local g (bind ask (env : pure env))))"
, " (inner :"
, " bind ask (after :"
, " pure (pair inner after))))"
]
final @?= Fork (ofString "root-f-g") (ofString "root")
, testCase "local result passes through bind correctly" $ do
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
unlines
[ "main = io (bind"
, " (local (env : append env \"-local\") (pure \"value\"))"
, " (x : pure x))"
]
final @?= ofString "value"
, testCase "IO inside local uses transformed environment and restores after" $ do
final <- runIOSourceWithEnv unsafePerms (ofString "root") $
unlines
[ "main = io (bind"
, " (local (env : append env \"-local\")"
, " (bind ask (env : pure env)))"
, " (result :"
, " bind ask (after :"
, " pure (pair result after))))"
]
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 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"
-- State tests
, testCase "get returns initial state" $ do
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 42) $
unlines
[ "main = io (bind get (s : pure s))"
]
final @?= ofNumber 42
st @?= ofNumber 42
, testCase "put updates state" $ do
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
unlines
[ "main = io (bind (put 100) (_ : bind get (s : pure s)))"
]
final @?= ofNumber 100
st @?= ofNumber 100
, testCase "state persists through bind" $ do
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 5) $
unlines
[ "main = io (bind get (s1 :"
, " bind (put (succ s1)) (_ :"
, " bind get (s2 :"
, " pure (pair s1 s2)))))"
]
final @?= Fork (ofNumber 5) (ofNumber 6)
st @?= ofNumber 6
, testCase "local does not restore state" $ do
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
unlines
[ "main = io (bind (put 10) (_ :"
, " bind (local (env : env) (put 20)) (_ :"
, " bind get (s :"
, " pure s))))"
]
final @?= ofNumber 20
st @?= ofNumber 20
, testCase "state and reader are independent" $ do
(final, st) <- runIOSourceWith unsafePerms (ofString "hello") (ofNumber 42) $
unlines
[ "main = io (bind ask (env :"
, " bind get (s :"
, " pure (pair env s))))"
]
final @?= Fork (ofString "hello") (ofNumber 42)
st @?= ofNumber 42
-- Async tests
, testCase "fork returns handle and await returns child value" $ do
(final, st) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (bind (fork (pure \"child\")) (h :"
, " await h))"
]
final @?= ofString "child"
st @?= Leaf
, testCase "main completion abandons unawaited child" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (bind (fork (pure \"child\")) (_ :"
, " pure \"main\"))"
]
final @?= ofString "main"
, testCase "fork captures reader environment at fork point" $ do
(final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
unlines
[ "main = io (local (env : append env \"-local\")"
, " (bind (fork (bind ask (env : pure env))) (h :"
, " await h)))"
]
final @?= ofString "root-local"
, testCase "fork inside local captures child env and parent restores env" $ do
(final, _) <- runIOSourceWith unsafePerms (ofString "root") Leaf $
unlines
[ "main = io (bind"
, " (local (env : append env \"-local\")"
, " (fork (bind ask (env : pure env))))"
, " (h : bind ask (after :"
, " bind (await h) (child :"
, " pure (pair after child)))))"
]
final @?= Fork (ofString "root") (ofString "root-local")
, testCase "fork copies state and child state does not merge" $ do
(final, st) <- runIOSourceWith unsafePerms Leaf (ofNumber 0) $
unlines
[ "main = io (bind (put 1) (_ :"
, " bind (fork (bind (put 99) (_ : bind get (s : pure s)))) (h :"
, " bind (put 2) (_ :"
, " bind (await h) (childState :"
, " bind get (parentState :"
, " pure (pair childState parentState)))))))"
]
final @?= Fork (ofNumber 99) (ofNumber 2)
st @?= ofNumber 2
, testCase "multiple awaiters receive same completed value" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (bind (fork (pure \"done\")) (h :"
, " bind (await h) (a :"
, " bind (await h) (b :"
, " pure (pair a b)))))"
]
final @?= Fork (ofString "done") (ofString "done")
, testCase "self await returns async error" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (await (pair \"task\" 0))"
]
final @?= ioErrResult 61
, testCase "await invalid handle returns async error" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (await 123)"
]
final @?= ioErrResult 60
, testCase "yield returns unit and resumes continuation" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (bind yield (_ : pure \"after\"))"
]
final @?= ofString "after"
, testCase "sleep resumes continuation" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (bind (sleep 1) (_ : pure \"awake\"))"
]
final @?= ofString "awake"
, testCase "await waits for sleeping child" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (bind (fork (bind (sleep 1) (_ : pure \"awake\"))) (h :"
, " await h))"
]
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 "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 $
unlines
[ "main = io (bind (fork (pure \"child done\")) (h :"
, " await h))"
]
final @?= ofString "child done"
st @?= Leaf
]
runIOSource :: String -> IO T
runIOSource source = do
runIOSourceWith :: IOPermissions -> T -> T -> String -> IO (T, T)
runIOSourceWith perms readerEnv initialState source = do
ioEnv <- evaluateFile "./lib/io.tri"
env <- evalTricuWithStore Nothing ioEnv (parseTricu source)
case checkIOSentinel (mainResult env) of
Right (1, action) -> runIO unsafePerms action
evalEnv <- evalTricuWithStore Nothing ioEnv (parseTricu source)
case checkIOSentinel (mainResult evalEnv) of
Right (1, action) -> runIOWith perms readerEnv initialState action
Right (v, _) -> assertFailure ("Unsupported IO ABI version: " ++ show v)
Left err -> assertFailure ("Expected IO sentinel: " ++ err)
runIOSource :: String -> IO T
runIOSource source = fmap fst $ runIOSourceWith unsafePerms Leaf Leaf source
runIOSourceWithPerms :: IOPermissions -> String -> IO T
runIOSourceWithPerms perms source = fmap fst $ runIOSourceWith perms Leaf Leaf source
runIOSourceWithEnv :: IOPermissions -> T -> String -> IO T
runIOSourceWithEnv perms readerEnv source = fmap fst $ runIOSourceWith perms readerEnv Leaf source
ioOkResult :: T -> T
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
ioErrResult :: Integer -> T
ioErrResult code = Fork Leaf (Fork (ofNumber code) Leaf)