commit af1c5829148422d4424b010bcd33b68c075f168b
parent 79a6f02864de4131112393671d27f6333273240c
Author: James Eversole <james@eversole.co>
Date: Tue, 12 May 2026 18:38:24 -0500
Interaction Tree IO
Diffstat:
8 files changed, 349 insertions(+), 20 deletions(-)
diff --git a/lib/base.tri b/lib/base.tri
@@ -72,3 +72,18 @@ succ = y (self :
(t (t t))
(_ tail : t t (self tail))
t))
+
+ok = value rest : pair true (pair value rest)
+err = code rest : pair false (pair code rest)
+
+matchResult = (errCase okCase result :
+ matchPair
+ (tag payload :
+ matchPair
+ (value rest :
+ matchBool
+ (okCase value rest)
+ (errCase value rest)
+ tag)
+ payload)
+ result)
diff --git a/lib/binary.tri b/lib/binary.tri
@@ -6,21 +6,6 @@ errUnexpectedEof = 1
errUnexpectedBytes = 2
errUnexpectedByte = 3
-ok = value rest : pair true (pair value rest)
-err = code rest : pair false (pair code rest)
-
-matchResult = (errCase okCase result :
- matchPair
- (tag payload :
- matchPair
- (value rest :
- matchBool
- (okCase value rest)
- (errCase value rest)
- tag)
- payload)
- result)
-
readU8 = (bytes : matchList
(err errUnexpectedEof t)
(h r : ok h r)
diff --git a/lib/conversions.tri b/lib/conversions.tri
@@ -0,0 +1,39 @@
+!import "base.tri" !Local
+!import "list.tri" !Local
+
+pred = y (self : triage
+ 0
+ (_ : 0)
+ (bit rest :
+ matchBool
+ -- odd: 2n + 1 -> 2n
+ (matchBool
+ 0
+ (pair 0 rest)
+ (equal? rest 0))
+ -- even: 2n -> 2n - 1
+ (matchBool
+ 0
+ (pair 1 (self rest))
+ (equal? rest 0))
+ bit))
+
+incDecRev = y (self : matchList
+ "1"
+ (digit rest :
+ matchBool
+ (pair 48 (self rest))
+ (pair (succ digit) rest)
+ (equal? digit 57)))
+
+showNumberRev_ = y (self n acc :
+ matchBool
+ acc
+ (self (pred n) (incDecRev acc))
+ (equal? n 0))
+
+showNumber = (n :
+ matchBool
+ "0"
+ (reverse (showNumberRev_ n t))
+ (equal? n 0))
diff --git a/lib/io.tri b/lib/io.tri
@@ -0,0 +1,82 @@
+!import "base.tri" !Local
+!import "list.tri" !Local
+!import "conversions.tri" !Local
+
+-- IO constructors for host-interpreted interaction trees.
+-- See docs/io-in-tricu.md for the full protocol.
+
+version = 1
+
+io = action : pair "tricuIO" (pair version action)
+pure = x : pair 0 x
+putStr = s k : pair 1 (pair s k)
+getLine = k : pair 2 k
+readFile = p k : pair 3 (pair p k)
+writeFile = p c k : pair 4 (pair p (pair c k))
+
+-- ---------------------------------------------------------------------------
+-- CPS sequencing helpers
+-- ---------------------------------------------------------------------------
+
+-- Print a string and finish successfully.
+print = s : putStr s (_ : pure t)
+
+-- Print a string plus newline and finish successfully.
+printLn = s : putStr (append s "\n") (_ : pure t)
+
+-- CPS print with newline.
+putStrLn = s k : putStr (append s "\n") k
+
+-- Sequence after putStr, ignoring Unit.
+afterPutStr = s next : putStr s (_ : next)
+
+-- Sequence after putStrLn, ignoring Unit.
+afterPutStrLn = s next : putStr (append s "\n") (_ : next)
+
+-- ---------------------------------------------------------------------------
+-- Result-aware file helpers
+-- ---------------------------------------------------------------------------
+
+-- Read a file, forcing the caller to handle both success and error.
+onReadFile = (path errCase okCase :
+ readFile path (result :
+ matchResult errCase okCase result))
+
+-- Write a file, forcing the caller to handle both success and error.
+onWriteFile = (path contents errCase okCase :
+ writeFile path contents (result :
+ matchResult errCase okCase result))
+
+-- ---------------------------------------------------------------------------
+-- Convenience helpers for the common cases
+-- ---------------------------------------------------------------------------
+
+-- Read a file; on error print a message and finish.
+readFileOrPrintError = (path okCase :
+ onReadFile path
+ (err rest :
+ putStrLn "Read failed" (_ :
+ pure t))
+ okCase)
+
+-- Write a file; on error print a message and finish.
+writeFileOrPrintError = (path contents okCase :
+ onWriteFile path contents
+ (err rest :
+ putStrLn "Write failed" (_ :
+ pure t))
+ okCase)
+
+-- Copy src to dst, then continue with k on success.
+copyFile = (src dst k :
+ onReadFile src
+ (err rest :
+ putStrLn "Read failed" (_ :
+ pure t))
+ (contents rest :
+ onWriteFile dst contents
+ (err rest :
+ putStrLn "Write failed" (_ :
+ pure t))
+ (ok rest :
+ k t)))
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -0,0 +1,120 @@
+module IODriver
+ ( IOPermissions(..)
+ , defaultPerms
+ , checkIOSentinel
+ , runIO
+ ) where
+
+import Research (T(..), apply, toString, toNumber, ofString, ofNumber)
+import System.IO (putStr, getLine)
+import qualified System.IO as IO
+import Control.Exception (try, IOException)
+import Control.Monad (unless)
+import System.Exit (die)
+import System.IO.Error (isDoesNotExistError, isPermissionError, isAlreadyExistsError)
+import Data.List (isPrefixOf)
+
+data IOPermissions = IOPermissions
+ { allowRead :: [FilePath]
+ , allowWrite :: [FilePath]
+ }
+
+defaultPerms :: IOPermissions
+defaultPerms = IOPermissions [] []
+
+checkIOSentinel :: T -> Either String (Integer, T)
+checkIOSentinel tree =
+ case tree of
+ Fork sentinel (Fork version action) -> do
+ s <- toString sentinel
+ case s of
+ "tricuIO" -> do
+ v <- toNumber version
+ return (v, action)
+ _ -> Left "sentinel mismatch (expected \"tricuIO\")"
+ _ -> Left "root is not an IO sentinel pair"
+
+runIO :: IOPermissions -> T -> IO T
+runIO perms actionTree = go actionTree
+ where
+ go tree =
+ case tree of
+ Fork tag payload -> do
+ tagNum <- case toNumber tag of
+ Right n -> return n
+ Left err -> die $ "Invalid IO action tag: " ++ err
+ dispatch tagNum payload
+ _ -> die $ "Invalid IO action tree: expected pair tag payload, got " ++ show tree
+
+ dispatch tagNum payload = case tagNum of
+ 0 -> return payload -- Pure
+
+ 1 -> case payload of
+ Fork str k -> do
+ s <- decodeString str "PutStr"
+ putStr s
+ go (apply k Leaf)
+ _ -> die "Invalid PutStr payload: expected pair string continuation"
+
+ 2 -> do
+ line <- getLine
+ go (apply payload (ofString line))
+
+ 3 -> case payload of
+ Fork path k -> do
+ p <- decodeString path "ReadFile"
+ checkReadPerm p
+ content <- tryReadFile p
+ go (apply k content)
+ _ -> die "Invalid ReadFile payload: expected pair path continuation"
+
+ 4 -> case payload of
+ Fork path rest -> case rest of
+ Fork contents k -> do
+ p <- decodeString path "WriteFile"
+ c <- decodeString contents "WriteFile"
+ checkWritePerm p
+ res <- tryWriteFile p c
+ go (apply k res)
+ _ -> die "Invalid WriteFile payload: expected pair contents continuation"
+ _ -> die "Invalid WriteFile payload: expected pair path (pair contents continuation)"
+
+ _ -> die $ "Unknown IO action tag: " ++ show tagNum
+
+ decodeString t ctx =
+ case toString t of
+ Right s -> return s
+ Left err -> die $ "Invalid " ++ ctx ++ " string: " ++ err
+
+ checkReadPerm p =
+ unless (pathAllowed p (allowRead perms)) $
+ die $ "Permission denied: read not allowed for " ++ p
+
+ checkWritePerm p =
+ unless (pathAllowed p (allowWrite perms)) $
+ die $ "Permission denied: write not allowed for " ++ p
+
+ pathAllowed _ [] = True -- No restrictions
+ pathAllowed p prefixes = any (\prefix -> prefix `isPrefixOf` p) prefixes
+
+ tryReadFile path = do
+ result <- try (IO.readFile path) :: IO (Either IOException String)
+ case result of
+ Right content -> return $ okResult (ofString content)
+ Left e -> return $ errResult (ioErrorCode e)
+
+ tryWriteFile path contents = do
+ result <- try (IO.writeFile path contents) :: IO (Either IOException ())
+ case result of
+ Right () -> return $ okResult Leaf
+ Left e -> return $ errResult (ioErrorCode e)
+
+ okResult val = Fork (Stem Leaf) (Fork val Leaf) -- pair true (pair val t)
+ errResult code = Fork Leaf (Fork (ofNumber code) Leaf) -- pair false (pair code t)
+
+ ioErrorCode :: IOException -> Integer
+ ioErrorCode e
+ | isDoesNotExistError e = 1
+ | isPermissionError e = 2
+ | isAlreadyExistsError e = 3
+ | otherwise = 4
diff --git a/src/Main.hs b/src/Main.hs
@@ -5,6 +5,7 @@ import System.Exit (die)
import Server (runServerWithPath)
import Eval (evalTricu, evalTricuWithStore, mainResult, result)
import FileEval (evaluateFileWithContext, evaluateFileWithStore, compileFile)
+import IODriver (IOPermissions(..), checkIOSentinel, runIO)
import Parser (parseTricu)
import REPL (repl)
import Research (T, EvaluatedForm(..), Env, formatT, exportDag)
@@ -32,10 +33,13 @@ import System.Environment (lookupEnv)
data TricuArgs
= Repl
| Eval
- { evalFiles :: [FilePath]
- , evalFormat :: EvaluatedForm
- , evalOutput :: FilePath
- , evalDb :: Maybe FilePath
+ { evalFiles :: [FilePath]
+ , evalFormat :: EvaluatedForm
+ , evalOutput :: FilePath
+ , evalDb :: Maybe FilePath
+ , evalIo :: Bool
+ , evalAllowRead :: [FilePath]
+ , evalAllowWrite :: [FilePath]
}
| ArboricxCompile
{ compileInput :: FilePath
@@ -98,6 +102,20 @@ evalParser = Eval
<> metavar "PATH"
<> help "Content store database path"
))
+ <*> switch
+ ( long "io"
+ <> help "Interpret the result as an IO action tree and execute it"
+ )
+ <*> many (option str
+ ( long "allow-read"
+ <> metavar "PATH"
+ <> help "Allow reading from PATH prefix (repeatable)"
+ ))
+ <*> many (option str
+ ( long "allow-write"
+ <> metavar "PATH"
+ <> help "Allow writing to PATH prefix (repeatable)"
+ ))
compileParser :: Parser TricuArgs
compileParser = ArboricxCompile
@@ -273,10 +291,18 @@ runEval opts = do
_ -> do
finalEnv <- foldM (evaluateFileWithStore mconn) Map.empty files
return $ mainResult finalEnv
+ finalT <- if evalIo opts
+ then case checkIOSentinel resultT of
+ Right (1, action) -> do
+ let perms = IOPermissions (evalAllowRead opts) (evalAllowWrite opts)
+ runIO perms action
+ Right (v, _) -> die $ "Unsupported IO ABI version: " ++ show v
+ Left err -> die $ "IO mode requested but " ++ err
+ else return resultT
case mconn of
Just conn -> close conn
Nothing -> return ()
- writeOutput out (formatT form resultT)
+ writeOutput out (formatT form finalT)
runCompile :: TricuArgs -> IO ()
runCompile opts = do
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -8,10 +8,12 @@ import REPL
import Research
import Wire
import ContentStore
+import IODriver
import Control.Exception (evaluate, try, SomeException)
import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
+import System.IO.Temp (withSystemTempDirectory)
import Data.Bits (xor)
import Data.Char (digitToInt)
import Data.List (isInfixOf)
@@ -51,6 +53,7 @@ tests = testGroup "Tricu Tests"
, wireTests
, tricuReaderTests
, byteListUtilities
+ , ioDriverTests
]
lexer :: TestTree
@@ -1252,3 +1255,58 @@ byteListUtilities = testGroup "Byte List Utility Tests"
let env = evalTricu library (parseTricu input)
result env @?= falseT
]
+
+-- --------------------------------------------------------------------------
+-- IO driver tests
+-- --------------------------------------------------------------------------
+
+ioDriverTests :: TestTree
+ioDriverTests = testGroup "IO driver tests"
+ [ testCase "readFile through onReadFile returns file contents" $
+ withSystemTempDirectory "tricu-io-read" $ \dir -> do
+ let sourcePath = dir ++ "/input.txt"
+ writeFile sourcePath "abc123"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onReadFile \"" ++ sourcePath ++ "\""
+ , " (err rest : pure \"read failed\")"
+ , " (contents rest : pure contents))"
+ ]
+ final @?= ofString "abc123"
+
+ , testCase "readFile error path returns explicit error branch" $
+ withSystemTempDirectory "tricu-io-read-missing" $ \dir -> do
+ let sourcePath = dir ++ "/missing.txt"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onReadFile \"" ++ sourcePath ++ "\""
+ , " (err rest : pure \"read failed\")"
+ , " (contents rest : pure contents))"
+ ]
+ final @?= ofString "read failed"
+
+ , testCase "chains multiple readFile actions through Result-aware helper" $
+ withSystemTempDirectory "tricu-io-chain" $ \dir -> do
+ let firstPath = dir ++ "/first.txt"
+ secondPath = dir ++ "/second.txt"
+ writeFile firstPath "abc"
+ writeFile secondPath "def"
+ final <- runIOSource $
+ unlines
+ [ "main = io (onReadFile \"" ++ firstPath ++ "\""
+ , " (err rest : pure \"first read failed\")"
+ , " (first rest : onReadFile \"" ++ secondPath ++ "\""
+ , " (err rest : pure \"second read failed\")"
+ , " (second rest : pure (append first second))))"
+ ]
+ final @?= ofString "abcdef"
+ ]
+
+runIOSource :: String -> IO T
+runIOSource source = do
+ ioEnv <- evaluateFile "./lib/io.tri"
+ env <- evalTricuWithStore Nothing ioEnv (parseTricu source)
+ case checkIOSentinel (mainResult env) of
+ Right (1, action) -> runIO defaultPerms action
+ Right (v, _) -> assertFailure ("Unsupported IO ABI version: " ++ show v)
+ Left err -> assertFailure ("Expected IO sentinel: " ++ err)
diff --git a/tricu.cabal b/tricu.cabal
@@ -68,6 +68,7 @@ executable tricu
ContentStore
Eval
FileEval
+ IODriver
Lexer
Parser
Paths_tricu
@@ -109,9 +110,11 @@ test-suite tricu-tests
, stm
, tasty
, tasty-hunit
+ , temporary
, text
, time
, transformers
+ , unix
, vector
, wai
, warp
@@ -121,6 +124,7 @@ test-suite tricu-tests
ContentStore
Eval
FileEval
+ IODriver
Lexer
Parser
Paths_tricu
