Strings for IO driver errors
This commit is contained in:
@@ -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.
|
||||
--
|
||||
|
||||
@@ -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
|
||||
|
||||
@@ -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))
|
||||
|
||||
45
src/Eval.hs
45
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
|
||||
| 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 == evalASTSync env body -> env
|
||||
| existingValue == res -> env
|
||||
| otherwise
|
||||
-> let res = evalASTSync env body
|
||||
in Map.insert "!result" res (Map.insert name res env)
|
||||
-> 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)
|
||||
-> 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
|
||||
|
||||
@@ -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
|
||||
|
||||
22
test/Spec.hs
22
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)
|
||||
|
||||
Reference in New Issue
Block a user