feat(haskell): Interaction Tree IO

oops, now we have purely modelled IO 🤷

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)

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)

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))

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)))

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

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)
@@ -36,6 +37,9 @@ data TricuArgs
       , 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

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)

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