commit 512c8b3056d2dbf5c1a3df9a18e3ab83a5360cd5
parent bb6af02a8489d0309f46de6c631bff001cb914b9
Author: James Eversole <james@eversole.co>
Date: Mon, 18 May 2026 18:28:24 -0500
Strings for IO driver errors
Diffstat:
6 files changed, 69 insertions(+), 102 deletions(-)
diff --git a/demos/interactionTrees.tri b/demos/interactionTrees.tri
@@ -26,7 +26,7 @@
--
-- File operations return a Result tree (see lib/base.tri):
-- ok value -- pair true (pair value t)
--- err code -- pair false (pair code t)
+-- err msg -- pair false (pair msg t)
--
-- Use onReadFile / onWriteFile for convenient branching.
--
diff --git a/lib/base.tri b/lib/base.tri
@@ -74,7 +74,7 @@ succ = y (self :
t))
ok = value rest : pair true (pair value rest)
-err = code rest : pair false (pair code rest)
+err = msg rest : pair false (pair msg rest)
matchResult = (errCase okCase result :
matchPair
diff --git a/lib/io.tri b/lib/io.tri
@@ -63,24 +63,24 @@ onWriteFile = (path contents errCase okCase :
readFileOrPrintError = (path okCase :
onReadFile path
- (err rest : putStrLn "Read failed")
+ (err rest : putStrLn (append "Read failed: " err))
okCase)
writeFileOrPrintError = (path contents okCase :
onWriteFile path contents
- (err rest : putStrLn "Write failed")
+ (err rest : putStrLn (append "Write failed: " err))
okCase)
copyFile = (src dst :
bind (readFile src)
(result :
matchResult
- (err rest : putStrLn "Read failed")
+ (err rest : putStrLn (append "Read failed: " err))
(contents rest :
bind (writeFile dst contents)
(wr :
matchResult
- (err rest : putStrLn "Write failed")
+ (err rest : putStrLn (append "Write failed: " err))
(ok rest : pure t)
wr))
result))
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -33,16 +33,15 @@ type Uses = [Bool]
evalSingle :: Env -> TricuAST -> Env
evalSingle env term
- | SDef name [] body <- term
- = case Map.lookup name env of
- Just existingValue
- | existingValue == evalASTSync env body -> env
- | otherwise
- -> let res = evalASTSync env body
- in Map.insert "!result" res (Map.insert name res env)
- Nothing
- -> let res = evalASTSync env body
- in Map.insert "!result" res (Map.insert name res env)
+ | SDef name params body <- term
+ = let res = evalASTSync env (if null params then body else SLambda params body)
+ in case Map.lookup name env of
+ Just existingValue
+ | existingValue == res -> env
+ | otherwise
+ -> Map.insert "!result" res (Map.insert name res env)
+ Nothing
+ -> Map.insert "!result" res (Map.insert name res env)
| SApp func arg <- term
= let res = apply (evalASTSync env func) (evalASTSync env arg)
in Map.insert "!result" res env
@@ -57,7 +56,7 @@ evalSingle env term
in Map.insert "!result" res env
evalTricu :: Env -> [TricuAST] -> Env
-evalTricu env x = go env (reorderDefs env x)
+evalTricu env x = go env (reorderDefs env (map recoverParams x))
where
go env' [] = env'
go env' [def] =
@@ -102,11 +101,10 @@ evalASTWithEnv mconn localEnv ast = do
let combinedEnv = Map.union localEnv storeEnv
return $ evalASTSync combinedEnv ast
--- | Store-aware version of 'evalSingle'.
evalSingleWithStore :: Maybe Connection -> Env -> TricuAST -> IO Env
evalSingleWithStore mconn env term
- | SDef name [] body <- term = do
- res <- evalASTWithEnv mconn env body
+ | SDef name params body <- term = do
+ res <- evalASTWithEnv mconn env (if null params then body else SLambda params body)
case Map.lookup name env of
Just existingValue
| existingValue == res -> return env
@@ -116,11 +114,8 @@ evalSingleWithStore mconn env term
res <- evalASTWithEnv mconn env term
return $ Map.insert "!result" res env
--- | Store-aware version of 'evalTricu'. Does not preload the entire
--- content store; terms are resolved on demand as variables are
--- encountered.
evalTricuWithStore :: Maybe Connection -> Env -> [TricuAST] -> IO Env
-evalTricuWithStore mconn env x = go env (reorderDefs env x)
+evalTricuWithStore mconn env x = go env (reorderDefs env (map recoverParams x))
where
go env' [] = return env'
go env' [def] = do
@@ -130,6 +125,10 @@ evalTricuWithStore mconn env x = go env (reorderDefs env x)
updatedEnv <- evalSingleWithStore mconn env' def
evalTricuWithStore mconn updatedEnv xs
+recoverParams :: TricuAST -> TricuAST
+recoverParams (SDef name [] (SLambda params body)) = SDef name params body
+recoverParams term = term
+
collectVarNames :: TricuAST -> [(String, Maybe String)]
collectVarNames = go []
where
@@ -189,6 +188,7 @@ elimLambda = go
| isSList term = slistTransform term
| otherwise = term
+ etaReduction (SLambda [v] (SVar x Nothing)) = v == x
etaReduction (SLambda [v] (SApp f (SVar x Nothing))) = v == x && not (usesBinder v f)
etaReduction _ = False
@@ -209,8 +209,9 @@ elimLambda = go
application (SApp _ _) = True
application _ = False
+ etaReduceResult (SLambda [_] (SVar _ Nothing)) = _I
etaReduceResult (SLambda [_] (SApp f _)) = f
- etaReduceResult _ = error "etaReduceResult: expected SLambda [v] (SApp f _)"
+ etaReduceResult _ = error "etaReduceResult: unexpected shape"
lambdaListResult (SLambda [v] (SList xs)) =
SLambda [v] (foldr wrapTLeaf TLeaf xs)
@@ -254,12 +255,12 @@ composeBody f g x = SApp (SVar f Nothing) (SApp (SVar g Nothing) (SVar x Nothin
isFree :: String -> TricuAST -> Bool
isFree x t = Set.member x (freeVars t)
--- Keep old freeVars for compatibility with reorderDefs which still uses TricuAST
freeVars :: TricuAST -> Set String
freeVars (SVar v Nothing) = Set.singleton v
freeVars (SVar v (Just _)) = Set.singleton v
freeVars (SApp t u) = Set.union (freeVars t) (freeVars u)
freeVars (SLambda vs body) = Set.difference (freeVars body) (Set.fromList vs)
+freeVars (SDef _ params body) = Set.difference (freeVars body) (Set.fromList params)
freeVars (TStem t) = freeVars t
freeVars (TFork t u) = Set.union (freeVars t) (freeVars u)
freeVars (SList xs) = foldMap freeVars xs
@@ -275,7 +276,7 @@ reorderDefs env defs
(defsOnly, others) = partition isDef defs
defNames = [ name | SDef name _ _ <- defsOnly ]
- defsWithFreeVars = [(def, freeVars body) | def@(SDef _ _ body) <- defsOnly]
+ defsWithFreeVars = [(def, freeVars def) | def <- defsOnly]
graph = buildDepGraph defsOnly
sortedDefs = sortDeps graph
@@ -298,8 +299,8 @@ buildDepGraph topDefs
"Conflicting definitions detected: " ++ show conflictingDefs
| otherwise =
Map.fromList
- [ (name, depends topDefs (SDef name [] body))
- | SDef name _ body <- topDefs]
+ [ (name, depends topDefs def)
+ | def@(SDef name _ _) <- topDefs]
where
defsMap = Map.fromListWith (++)
[(name, [(name, body)]) | SDef name _ body <- topDefs]
@@ -329,10 +330,10 @@ sortDeps graph = go [] Set.empty (Map.keys graph)
notReady
depends :: [TricuAST] -> TricuAST -> Set.Set String
-depends topDefs (SDef _ _ body) =
+depends topDefs def@(SDef _ _ _) =
Set.intersection
(Set.fromList [n | SDef n _ _ <- topDefs])
- (freeVars body)
+ (freeVars def)
depends _ _ = Set.empty
result :: Env -> T
diff --git a/src/IODriver.hs b/src/IODriver.hs
@@ -95,67 +95,33 @@ data Machine = Machine
--
-- Runtime protocol errors are returned as direct values via errResult.
--- Error code ranges:
--- 1-19 host IO / filesystem errors
--- 20-39 policy / permission errors
--- 40-59 protocol / decode / type errors
--- 60-79 async errors
--- 80-99 scheduler / runtime errors
-
--- Host IO / filesystem errors (1-19)
-errDoesNotExist, errPermission, errAlreadyExists, errIOOther :: Integer
-errDoesNotExist = 1
-errPermission = 2
-errAlreadyExists = 3
-errIOOther = 4
-
--- Policy / permission errors (20-39)
-errPolicyDeny :: Integer
-errPolicyDeny = 20
-
--- Protocol / decode / type errors (40-59)
-errInvalidAction, errInvalidString :: Integer
-errInvalidAction = 40
-errInvalidString = 41
-
--- Async errors (60-79)
-errInvalidHandle, errSelfAwait, errInvalidSleep, errCyclicAwait :: Integer
-errInvalidHandle = 60
-errSelfAwait = 61
-errInvalidSleep = 62
-errCyclicAwait = 63
-
--- Scheduler / runtime errors (80-99)
-errDeadlock :: Integer
-errDeadlock = 80
-
-ioErrorCode :: IOException -> Integer
-ioErrorCode e
- | isDoesNotExistError e = errDoesNotExist
- | isPermissionError e = errPermission
- | isAlreadyExistsError e = errAlreadyExists
- | otherwise = errIOOther
-
okResult :: T -> T
okResult val = Fork (Stem Leaf) (Fork val Leaf)
-errResult :: Integer -> T
-errResult code = Fork Leaf (Fork (ofNumber code) Leaf)
+errResult :: String -> T
+errResult msg = Fork Leaf (Fork (ofString msg) Leaf)
pureAction :: T -> T
pureAction x = Fork (ofNumber 0) x
invalidAsyncHandleResult :: T
-invalidAsyncHandleResult = errResult errInvalidHandle
+invalidAsyncHandleResult = errResult "invalid task handle"
selfAwaitResult :: T
-selfAwaitResult = errResult errSelfAwait
+selfAwaitResult = errResult "self await"
deadlockResult :: T
-deadlockResult = errResult errDeadlock
+deadlockResult = errResult "deadlock"
invalidSleepResult :: T
-invalidSleepResult = errResult errInvalidSleep
+invalidSleepResult = errResult "invalid sleep"
+
+ioErrorString :: IOException -> String
+ioErrorString e
+ | isDoesNotExistError e = "does not exist"
+ | isPermissionError e = "permission denied"
+ | isAlreadyExistsError e = "already exists"
+ | otherwise = "io error"
-- ---------------------------------------------------------------------------
-- Task identity and handles
@@ -350,7 +316,7 @@ stepMachine :: Machine -> IO Step
stepMachine machine =
case decodeAction (machineCurrent machine) of
Right action -> dispatch action
- Left _ -> finishValue machine (errResult errInvalidAction)
+ Left _ -> finishValue machine (errResult "invalid action")
where
dispatch action = case action of
APure val ->
@@ -367,14 +333,14 @@ stepMachine machine =
Right s ->
pure (AsyncAction (putStr s >> pure Leaf) machine)
Left _ ->
- finishValue machine (errResult errInvalidString)
+ finishValue machine (errResult "invalid string")
APutBytes bs ->
case decodeBytes bs "PutBytes" of
Right b ->
pure (AsyncAction (BS.putStr b >> pure Leaf) machine)
Left _ ->
- finishValue machine (errResult errInvalidString)
+ finishValue machine (errResult "invalid bytes")
AGetLine ->
pure (AsyncAction (ofString <$> getLine) machine)
@@ -386,7 +352,7 @@ stepMachine machine =
case mDeny of
Just denied -> finishValue machine denied
Nothing -> pure (AsyncAction (tryReadFile p) machine)
- Left _ -> finishValue machine (errResult errInvalidString)
+ Left _ -> finishValue machine (errResult "invalid string")
AWriteFile path contents ->
case decodeString path "WriteFile" of
@@ -397,8 +363,8 @@ stepMachine machine =
case mDeny of
Just denied -> finishValue machine denied
Nothing -> pure (AsyncAction (tryWriteFile p c) machine)
- Left _ -> finishValue machine (errResult errInvalidString)
- Left _ -> finishValue machine (errResult errInvalidString)
+ Left _ -> finishValue machine (errResult "invalid string")
+ Left _ -> finishValue machine (errResult "invalid string")
AWriteBytes path contents ->
case decodeString path "WriteBytes" of
@@ -409,8 +375,8 @@ stepMachine machine =
case mDeny of
Just denied -> finishValue machine denied
Nothing -> pure (AsyncAction (tryWriteFileBytes p c) machine)
- Left _ -> finishValue machine (errResult errInvalidString)
- Left _ -> finishValue machine (errResult errInvalidString)
+ Left _ -> finishValue machine (errResult "invalid bytes")
+ Left _ -> finishValue machine (errResult "invalid string")
AAsk ->
finishValue machine (rtEnv (machineRuntime machine))
@@ -480,7 +446,7 @@ stepMachine machine =
then return Nothing
else return $ Just policyErrResult
- policyErrResult = errResult errPolicyDeny
+ policyErrResult = errResult "permission denied"
canonicalizeSafe :: FilePath -> IO (Either String FilePath)
canonicalizeSafe p = do
@@ -534,19 +500,19 @@ stepMachine machine =
result <- try (BS.readFile path) :: IO (Either IOException BS.ByteString)
case result of
Right content -> return $ okResult (ofBytes content)
- Left e -> return $ errResult (ioErrorCode e)
+ Left e -> return $ errResult (ioErrorString 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)
+ Left e -> return $ errResult (ioErrorString e)
tryWriteFileBytes path contents = do
result <- try (BS.writeFile path contents) :: IO (Either IOException ())
case result of
Right () -> return $ okResult Leaf
- Left e -> return $ errResult (ioErrorCode e)
+ Left e -> return $ errResult (ioErrorString e)
decodeString t ctx =
case toString t of
@@ -732,7 +698,7 @@ handleStep currentId (AwaitRequested targetId machine) scheduler
Just (BlockedOn nextId _) ->
if wouldCycle targetId currentId (schedulerTasks scheduler)
- then resumeCurrentWith currentId (errResult errCyclicAwait) machine scheduler
+ then resumeCurrentWith currentId (errResult "cyclic await") machine scheduler
else block
Just _ -> block
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -1553,15 +1553,15 @@ ioDriverTests = testGroup "IO driver tests"
-- Malformed action tests
, testCase "unknown IO action tag returns err result" $ do
final <- runIOSource "main = io (pair 99 t)"
- final @?= ioErrResult 40
+ final @?= ioErrResult "invalid action"
, testCase "malformed Bind returns err result" $ do
final <- runIOSource "main = io (pair 1 t)"
- final @?= ioErrResult 40
+ final @?= ioErrResult "invalid action"
, testCase "malformed ReadFile payload returns err result" $ do
final <- runIOSource "main = io (readFile (t t))"
- final @?= ioErrResult 41
+ final @?= ioErrResult "invalid string"
-- Permission tests
, testCase "allowed read path succeeds" $
@@ -1586,7 +1586,7 @@ ioDriverTests = testGroup "IO driver tests"
unlines
[ "main = io (readFile \"" ++ deniedPath ++ "\")"
]
- result @?= ioErrResult 20
+ result @?= ioErrResult "permission denied"
, testCase "writeFile denied path returns err result" $
withSystemTempDirectory "tricu-io-write-denied" $ \dir -> do
@@ -1597,7 +1597,7 @@ ioDriverTests = testGroup "IO driver tests"
unlines
[ "main = io (writeFile \"" ++ deniedPath ++ "\" \"x\")"
]
- result @?= ioErrResult 20
+ result @?= ioErrResult "permission denied"
, testCase "path prefix does not allow prefix bypass" $
withSystemTempDirectory "tricu-io-prefix" $ \dir -> do
@@ -1611,7 +1611,7 @@ ioDriverTests = testGroup "IO driver tests"
unlines
[ "main = io (readFile \"" ++ bypassPath ++ "\")"
]
- result @?= ioErrResult 20
+ result @?= ioErrResult "permission denied"
-- Pure test
, testCase "pure performs no effects" $ do
@@ -1820,14 +1820,14 @@ ioDriverTests = testGroup "IO driver tests"
unlines
[ "main = io (await (pair \"task\" 0))"
]
- final @?= ioErrResult 61
+ final @?= ioErrResult "self await"
, testCase "await invalid handle returns async error" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
unlines
[ "main = io (await 123)"
]
- final @?= ioErrResult 60
+ final @?= ioErrResult "invalid task handle"
, testCase "yield returns unit and resumes continuation" $ do
(final, _) <- runIOSourceWith unsafePerms Leaf Leaf $
@@ -1890,7 +1890,7 @@ ioDriverTests = testGroup "IO driver tests"
[ "main = io (bind (fork (await (pair \"task\" 0))) (h :"
, " await h))"
]
- final @?= ioErrResult 63
+ final @?= ioErrResult "cyclic await"
, testCase "writeBytes and readFile roundtrip binary data" $
withSystemTempDirectory "tricu-io-bytes" $ \dir -> do
@@ -1942,5 +1942,5 @@ runIOSourceWithEnv perms readerEnv source = fmap fst $ runIOSourceWith perms rea
ioOkResult :: T -> T
ioOkResult val = Fork (Stem Leaf) (Fork val Leaf)
-ioErrResult :: Integer -> T
-ioErrResult code = Fork Leaf (Fork (ofNumber code) Leaf)
+ioErrResult :: String -> T
+ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)
