diff --git a/demos/interactionTrees.tri b/demos/interactionTrees.tri index 14d5c5f..d3ded5f 100644 --- 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 index 7eadaaf..a018a4d 100644 --- 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 index 9dcd9a9..165dfe3 100644 --- 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 index fcc4118..d7a23d6 100644 --- 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 index ead662e..9bb1ec9 100644 --- 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 index 9d0631e..8d14580 100644 --- 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)