Strings for IO driver errors

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

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

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

src/Eval.hs

@@ -33,16 +33,15 @@ type Uses = [Bool]
 
 evalSingle :: Env -> TricuAST -> Env
 evalSingle env term
-  | SDef name [] body <- term
+  | SDef name params body <- term
-  = case Map.lookup name env of
+  = let res = evalASTSync env (if null params then body else SLambda params body)
-      Just existingValue
+    in case Map.lookup name env of
-        | existingValue == evalASTSync env body -> env
+         Just existingValue
-        | otherwise
+           | existingValue == res -> env
-        -> let res = evalASTSync env body
+           | otherwise
-           in Map.insert "!result" res (Map.insert name res env)
+           -> Map.insert "!result" res (Map.insert name res env)
-      Nothing
+         Nothing
-        -> let res = evalASTSync env body
+           -> Map.insert "!result" res (Map.insert name res env)
-           in 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
+  | SDef name params body <- term = do
-      res <- evalASTWithEnv mconn env body
+      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))
+        [ (name, depends topDefs def)
-        | SDef name _ body <- topDefs]
+        | 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

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 :: String -> T
-errResult code = Fork Leaf (Fork (ofNumber code) Leaf)
+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 "invalid string")
-          Left _ -> finishValue machine (errResult errInvalidString)
+          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 "invalid bytes")
-          Left _ -> finishValue machine (errResult errInvalidString)
+          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

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 :: String -> T
-ioErrResult code = Fork Leaf (Fork (ofNumber code) Leaf)
+ioErrResult msg = Fork Leaf (Fork (ofString msg) Leaf)