diff --git a/demos/interactionTrees.tri b/demos/interactionTrees.tri new file mode 100644 index 0000000..14d5c5f --- /dev/null +++ b/demos/interactionTrees.tri @@ -0,0 +1,58 @@ +!import "../lib/base.tri" !Local +!import "../lib/list.tri" !Local +!import "../lib/io.tri" !Local + +-- Interaction Tree Effect Runtime +-- +-- The IO system is an interaction-tree effect runtime interpreted by a +-- small-step machine with a cooperative scheduler. Primitive actions +-- (putStr, readFile, writeFile, ...) are tagged nodes in an interaction +-- tree. Sequencing is performed by the single generic `bind` constructor. +-- +-- pure x -- lift a pure value into IO +-- bind action k -- run action, then apply k to its result +-- thenIO a b -- run a, discard its result, then run b +-- mapIO action f -- run action, then apply f to its result inside pure +-- +-- The runtime supports several effects beyond basic IO: +-- ask -- read the current environment +-- local f action -- run action with environment transformed by f +-- get -- read the current mutable state +-- put s -- replace the mutable state +-- fork action -- spawn a concurrent task, returning a handle +-- await handle -- wait for a forked task to complete +-- yield -- yield control to the scheduler +-- sleep ms -- suspend current task for N milliseconds +-- +-- File operations return a Result tree (see lib/base.tri): +-- ok value -- pair true (pair value t) +-- err code -- pair false (pair code t) +-- +-- Use onReadFile / onWriteFile for convenient branching. +-- +-- See demos/interactionTrees/ for smaller focused examples. + +-- Cooperative async demo. +-- fork runs an action in the background. +-- sleep suspends the current task for N milliseconds. +-- await waits for a forked task and returns its value. +-- +-- Here the child sleeps for 2 s while the parent prints immediately. +-- The parent's message appears first, proving interleaving. + +asyncDemo = ( + bind (fork + (bind (sleep 2000) (_ : + bind (putStrLn "2000ms done sleeping!") (_ : + pure "child2000 done")))) + (handle2000 : + bind (fork + (bind (sleep 5000) (_ : + bind (putStrLn "5000ms done sleeping!") (_ : + pure "child5000 done")))) + (handle5000 : + bind (putStrLn "Parent first!") (_ : + bind (await handle5000) (_ : + await handle2000))))) + +main = io asyncDemo diff --git a/demos/interactionTrees/environment.tri b/demos/interactionTrees/environment.tri new file mode 100644 index 0000000..543d4d0 --- /dev/null +++ b/demos/interactionTrees/environment.tri @@ -0,0 +1,20 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Environment effects: ask and local. +-- ask reads the current environment value. +-- local f action runs action with the env transformed by f. +-- +-- The CLI starts with an empty (Leaf) environment. This demo uses +-- local to inject a real string so that ask returns something readable. + +main = io <| + (bind + local (_ : "sandbox") + (bind ask (env : + bind (putStrLn (append "working in env: " env)) (_ : + pure "inside-done")))) + (outside : + bind (putStrLn (append "local returned: " outside)) (_ : + pure t)) diff --git a/demos/interactionTrees/forkAwait.tri b/demos/interactionTrees/forkAwait.tri new file mode 100644 index 0000000..8034c4d --- /dev/null +++ b/demos/interactionTrees/forkAwait.tri @@ -0,0 +1,18 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Basic fork and await. +-- fork spawns a concurrent task and returns a handle. +-- await blocks until the task completes and returns its value. + +worker = (msg : + bind (putStrLn (append "working: " msg)) (_ : + pure (append msg "-result"))) + +main = io <| + (bind (fork (worker "job1")) (h1 : + bind (fork (worker "job2")) (h2 : + bind (await h1) (r1 : + bind (await h2) (r2 : + putStrLn (append "Got " (append r1 (append " and " r2)))))))) diff --git a/demos/interactionTrees/greet.tri b/demos/interactionTrees/greet.tri new file mode 100644 index 0000000..1d4e4ee --- /dev/null +++ b/demos/interactionTrees/greet.tri @@ -0,0 +1,10 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Greet and return a pure value. +-- putStrLn writes to stdout; pure lifts "done" into IO. + +main = io (bind + (putStrLn (append "Hello, " "tricu")) + (_ : pure "")) diff --git a/demos/interactionTrees/safeRead.tri b/demos/interactionTrees/safeRead.tri new file mode 100644 index 0000000..b70efe8 --- /dev/null +++ b/demos/interactionTrees/safeRead.tri @@ -0,0 +1,16 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- readFile returns a Result. matchResult branches on ok / err. +-- Run with --allow-read PATH or --unsafe-io. + +safeRead = (path : + bind (readFile path) + (result : + matchResult + (err rest : pure "ERROR: Unable to read file") + (contents rest : pure contents) + result)) + +main = io (safeRead "demos/interactionTrees/greet.tri") diff --git a/demos/interactionTrees/shout.tri b/demos/interactionTrees/shout.tri new file mode 100644 index 0000000..8ca9481 --- /dev/null +++ b/demos/interactionTrees/shout.tri @@ -0,0 +1,23 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Transform an IO result. +-- mapIO applies a pure function to the value produced by an action. +-- Run with --allow-read PATH or --unsafe-io. + +safeRead = (path : + bind (readFile path) + (result : + matchResult + (err rest : pure "missing") + (contents rest : pure contents) + result)) + +shout = (path : + mapIO (safeRead path) + (text : append text "!!!")) + +main = io (bind + (shout "demos/interactionTrees/greet.tri") + (text : putStrLn text)) diff --git a/demos/interactionTrees/state.tri b/demos/interactionTrees/state.tri new file mode 100644 index 0000000..f986241 --- /dev/null +++ b/demos/interactionTrees/state.tri @@ -0,0 +1,22 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Mutable state via get and put. +-- get reads the current state. +-- put replaces the state. +-- +-- The CLI starts with an empty (Leaf) state. This demo puts +-- readable strings and prints them back out. + +main = io <| + bind (put "idle") (_ : + bind get (s1 : + bind (putStrLn (append "state: " s1)) (_ : + bind (put "running") (_ : + bind get (s2 : + bind (putStrLn (append "state: " s2)) (_ : + bind (put "done") (_ : + bind get (s3 : + bind (putStrLn (append "state: " s3)) (_ : + pure t))))))))) diff --git a/demos/interactionTrees/writeThenRead.tri b/demos/interactionTrees/writeThenRead.tri new file mode 100644 index 0000000..84f6d63 --- /dev/null +++ b/demos/interactionTrees/writeThenRead.tri @@ -0,0 +1,20 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Write a file, then read it back. +-- thenIO discards the writeFile Result and continues. +-- Run with --unsafe-io (needs both read and write permissions). + +writeThenRead = (path text : + thenIO + (writeFile path text) + (readFile path)) + +main = io <| + (bind (writeThenRead "/tmp/tricu-demo.txt" "hello from tricu") + (result : + matchResult + (err rest : putStrLn "error") + (contents rest : putStrLn contents) + result)) diff --git a/demos/interactionTrees/yield.tri b/demos/interactionTrees/yield.tri new file mode 100644 index 0000000..0f55a55 --- /dev/null +++ b/demos/interactionTrees/yield.tri @@ -0,0 +1,33 @@ +!import "../../lib/base.tri" !Local +!import "../../lib/list.tri" !Local +!import "../../lib/io.tri" !Local + +-- Cooperative scheduling with yield. +-- yield returns control to the scheduler so other tasks can run. +-- +-- Two tasks print alternately because each yields after every line. + +--chatter = (name n : +-- bind (putStrLn (append name " says 1")) (_ : +-- bind yield (_ : +-- bind (putStrLn (append name " says 2")) (_ : +-- bind yield (_ : +-- bind (putStrLn (append name " says 3")) (_ : +-- pure n)))))) + +chatter = name n : bind <| + putStrLn (append name " says 1") (_ : + bind yield (_ : + bind (putStrLn (append name " says 2")) (_ : + bind yield (_ : + bind (putStrLn (append name " says 3")) (_ : + pure n))))) + + +main = io <| + bind (fork (chatter "A" "doneA")) (ha : + bind (fork (chatter "B" "doneB")) (hb : + bind yield (_ : + bind (await ha) (a : + bind (await hb) (b : + putStrLn (append "Finished: " (append a (append " " b)))))))) diff --git a/demos/monadicIO.tri b/demos/monadicIO.tri deleted file mode 100644 index 47c4fcd..0000000 --- a/demos/monadicIO.tri +++ /dev/null @@ -1,86 +0,0 @@ -!import "../lib/base.tri" !Local -!import "../lib/list.tri" !Local -!import "../lib/io.tri" !Local - --- Monadic IO in tricu --- --- The IO system is a free monad interpreted by the host. Primitive actions --- (putStr, readFile, writeFile, ...) do not carry their own continuations. --- Sequencing is performed by the single generic `bind` constructor. --- --- pure x -- lift a pure value into IO --- bind action k -- run action, then apply k to its result --- thenIO a b -- run a, discard its result, then run b --- mapIO action f -- run action, then apply f to its result inside pure --- --- File operations return a Result tree (see lib/base.tri): --- ok value -- pair true (pair value t) --- err code -- pair false (pair code t) --- --- Use onReadFile / onWriteFile for convenient branching. - --- ---------------------------------------------------------------------------- --- Example 1: Greet and return a pure value. --- putStrLn writes to stdout; pure lifts "done" into IO. --- ---------------------------------------------------------------------------- - -greet = (name : - bind (putStrLn (append "Hello, " name)) - (_ : pure "done")) - --- ---------------------------------------------------------------------------- --- Example 2: Read a file safely. --- readFile returns a Result. matchResult branches on ok / err. --- ---------------------------------------------------------------------------- - -safeRead = (path : - bind (readFile path) - (result : - matchResult - (err rest : pure "missing") - (contents rest : pure contents) - result)) - --- ---------------------------------------------------------------------------- --- Example 3: Write, then read back. --- thenIO discards the writeFile Result and continues. --- ---------------------------------------------------------------------------- - -writeThenRead = (path text : - thenIO - (writeFile path text) - (readFile path)) - --- ---------------------------------------------------------------------------- --- Example 4: Transform an IO result. --- mapIO applies a pure function to the value produced by an action. --- ---------------------------------------------------------------------------- - -shout = (path : - mapIO (safeRead path) - (text : append text "!!!")) - --- ---------------------------------------------------------------------------- --- Example 5: Cooperative async. --- fork runs an action in the background. --- sleep suspends the current task for N milliseconds. --- await waits for a forked task and returns its value. --- --- Here the child sleeps for 2 s while the parent prints immediately. --- The parent's message appears first, proving interleaving. --- ---------------------------------------------------------------------------- - -asyncDemo = ( - bind (fork - (bind (sleep 2000) (_ : - bind (putStrLn "Done sleeping!") (_ : - pure "child done")))) - (handle : - bind (putStrLn "Parent first!") (_ : - await handle))) - --- ---------------------------------------------------------------------------- --- Main action - run the async demo. --- ---------------------------------------------------------------------------- - -main = io asyncDemo diff --git a/src/Lexer.hs b/src/Lexer.hs index 0b7f74a..8af95fb 100644 --- a/src/Lexer.hs +++ b/src/Lexer.hs @@ -45,6 +45,7 @@ tricuLexer = do , closeParen , openBracket , closeBracket + , try arrowLeft ] lexTricu :: String -> [LToken] @@ -128,6 +129,9 @@ openBracket = char '[' $> LOpenBracket closeBracket :: Lexer LToken closeBracket = char ']' $> LCloseBracket +arrowLeft :: Lexer LToken +arrowLeft = string "<|" $> LArrowLeft + lnewline :: Lexer LToken lnewline = char '\n' $> LNewline diff --git a/src/Parser.hs b/src/Parser.hs index 52adc48..6cc6585 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -10,313 +10,3 @@ import Data.Void (Void) import Text.Megaparsec import qualified Data.Set as Set - -data PState = PState - { parenDepth :: Int - , bracketDepth :: Int - } deriving (Show) - -type ParserM = StateT PState (Parsec Void [LToken]) - -satisfyM :: (LToken -> Bool) -> ParserM LToken -satisfyM f = do - tok <- lift (satisfy f) - modify' (updateDepth tok) - return tok - -updateDepth :: LToken -> PState -> PState -updateDepth LOpenParen st = st { parenDepth = parenDepth st + 1 } -updateDepth LOpenBracket st = st { bracketDepth = bracketDepth st + 1 } -updateDepth LCloseParen st = st { parenDepth = parenDepth st - 1 } -updateDepth LCloseBracket st = st { bracketDepth = bracketDepth st - 1 } -updateDepth _ st = st - -topLevelNewline :: ParserM () -topLevelNewline = do - st <- get - if parenDepth st == 0 && bracketDepth st == 0 - then void (satisfyM (== LNewline)) - else fail "Top-level exit in nested context (paren or bracket)" - -parseProgram :: [LToken] -> Either (ParseErrorBundle [LToken] Void) [TricuAST] -parseProgram toks = - runParser (evalStateT (parseProgramM <* finalizeDepth <* eof) (PState 0 0)) "" toks - -parseSingleExpr :: [LToken] -> Either (ParseErrorBundle [LToken] Void) TricuAST -parseSingleExpr toks = - runParser (evalStateT (scnParserM *> parseExpressionM <* finalizeDepth <* eof) (PState 0 0)) "" toks - -finalizeDepth :: ParserM () -finalizeDepth = do - st <- get - case (parenDepth st, bracketDepth st) of - (0, 0) -> pure () - (p, b) -> fail $ "Unmatched tokens: " ++ show (p, b) - -parseTricu :: String -> [TricuAST] -parseTricu input = - case lexTricu input of - [] -> [] - toks -> - case parseProgram toks of - Left err -> errorWithoutStackTrace (handleParseError err) - Right asts -> asts - -parseSingle :: String -> TricuAST -parseSingle input = - case lexTricu input of - [] -> SEmpty - toks -> - case parseSingleExpr toks of - Left err -> errorWithoutStackTrace (handleParseError err) - Right ast -> ast - -parseProgramM :: ParserM [TricuAST] -parseProgramM = do - skipMany topLevelNewline - importNodes <- many (do - node <- parseImportM - skipMany topLevelNewline - return node) - skipMany topLevelNewline - exprs <- sepEndBy parseOneExpression (some topLevelNewline) - skipMany topLevelNewline - return (importNodes ++ exprs) - -parseImportM :: ParserM TricuAST -parseImportM = do - LImport filePath moduleName <- satisfyM isImport - pure (SImport filePath moduleName) - where - isImport (LImport _ _) = True - isImport _ = False - -parseOneExpression :: ParserM TricuAST -parseOneExpression = scnParserM *> parseExpressionM - -scnParserM :: ParserM () -scnParserM = skipMany $ do - t <- lookAhead anySingle - st <- get - if | (parenDepth st > 0 || bracketDepth st > 0) && (t == LNewline) -> - void $ satisfyM (== LNewline) - | otherwise -> - fail "In nested context or no space token" <|> empty - -eofM :: ParserM () -eofM = lift eof - -parseExpressionM :: ParserM TricuAST -parseExpressionM = choice - [ try parseFunctionM - , try parseLambdaM - , try parseLambdaExpressionM - , try parseListLiteralM - , try parseApplicationM - , try parseTreeTermM - , parseLiteralM - ] - -parseFunctionM :: ParserM TricuAST -parseFunctionM = do - let ident = (\case LIdentifier _ -> True; _ -> False) - LIdentifier name <- satisfyM ident - args <- many $ satisfyM ident - _ <- satisfyM (== LAssign) - scnParserM - body <- parseExpressionM - pure (SDef name (map getIdentifier args) body) - -parseLambdaM :: ParserM TricuAST -parseLambdaM = do - let ident = (\case LIdentifier _ -> True; _ -> False) - params <- some (satisfyM ident) - _ <- satisfyM (== LColon) - scnParserM - body <- parseLambdaExpressionM - pure $ foldr (\param acc -> SLambda [getIdentifier param] acc) body params - -parseLambdaExpressionM :: ParserM TricuAST -parseLambdaExpressionM = choice - [ try parseLambdaApplicationM - , parseAtomicLambdaM - ] - -parseAtomicLambdaM :: ParserM TricuAST -parseAtomicLambdaM = choice - [ try parseLambdaM - , parseVarM - , parseTreeLeafM - , parseLiteralM - , parseListLiteralM - , between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseLambdaExpressionM - ] - -parseApplicationM :: ParserM TricuAST -parseApplicationM = do - func <- parseAtomicBaseM - scnParserM - args <- many $ do - scnParserM - arg <- parseAtomicM - return arg - return $ foldl SApp func args - -parseLambdaApplicationM :: ParserM TricuAST -parseLambdaApplicationM = do - func <- parseAtomicLambdaM - scnParserM - args <- many $ do - arg <- parseAtomicLambdaM - scnParserM - pure arg - pure $ foldl SApp func args - -parseAtomicBaseM :: ParserM TricuAST -parseAtomicBaseM = choice - [ parseTreeLeafM - , parseGroupedM - ] - -parseTreeLeafM :: ParserM TricuAST -parseTreeLeafM = do - let keyword = (\case LKeywordT -> True; _ -> False) - _ <- satisfyM keyword - notFollowedBy $ lift $ satisfy (== LAssign) - pure TLeaf - -parseTreeTermM :: ParserM TricuAST -parseTreeTermM = do - base <- parseTreeLeafOrParenthesizedM - rest <- many parseTreeLeafOrParenthesizedM - pure (foldl combine base rest) - where - combine acc next - | TLeaf <- acc = TStem next - | TStem t <- acc = TFork t next - | TFork _ _ <- acc = TFork acc next - | otherwise = SApp acc next - -parseTreeLeafOrParenthesizedM :: ParserM TricuAST -parseTreeLeafOrParenthesizedM = choice - [ between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) parseTreeTermM - , parseTreeLeafM - ] - -parseAtomicM :: ParserM TricuAST -parseAtomicM = choice - [ try parseLambdaM - , parseVarM - , parseTreeLeafM - , parseListLiteralM - , parseGroupedM - , parseLiteralM - ] - -parseGroupedM :: ParserM TricuAST -parseGroupedM = between (satisfyM (== LOpenParen)) (satisfyM (== LCloseParen)) $ - scnParserM *> parseExpressionM <* scnParserM - -parseLiteralM :: ParserM TricuAST -parseLiteralM = choice - [ parseIntLiteralM - , parseStrLiteralM - ] - -parseListLiteralM :: ParserM TricuAST -parseListLiteralM = do - _ <- satisfyM (== LOpenBracket) - elements <- many $ do - scnParserM - parseListItemM - scnParserM - _ <- satisfyM (== LCloseBracket) - pure (SList elements) - -parseListItemM :: ParserM TricuAST -parseListItemM = choice - [ parseGroupedItemM - , parseListLiteralM - , parseSingleItemM - ] - -parseGroupedItemM :: ParserM TricuAST -parseGroupedItemM = do - _ <- satisfyM (== LOpenParen) - inner <- parseExpressionM - _ <- satisfyM (== LCloseParen) - pure inner - -parseSingleItemM :: ParserM TricuAST -parseSingleItemM = do - tok <- satisfyM (\case LIdentifier _ -> True; LKeywordT -> True; _ -> False) - if | LIdentifier name <- tok -> pure (SVar name Nothing) - | tok == LKeywordT -> pure TLeaf - | otherwise -> fail "Unexpected token in list item" - -parseVarM :: ParserM TricuAST -parseVarM = do - tok <- satisfyM (\case - LNamespace _ -> True - LIdentifier _ -> True - LIdentifierWithHash _ _ -> True - _ -> False) - - case tok of - LNamespace ns -> do - _ <- satisfyM (== LDot) - LIdentifier name <- satisfyM (\case LIdentifier _ -> True; _ -> False) - pure $ SVar (ns ++ "." ++ name) Nothing - - LIdentifier name - | name == "t" || name == "!result" -> - fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") - | otherwise -> pure (SVar name Nothing) - - LIdentifierWithHash name hash -> - if name == "t" || name == "!result" - then fail ("Reserved keyword: " ++ name ++ " cannot be assigned.") - else pure (SVar name (Just hash)) - - _ -> fail "Unexpected token while parsing variable" - -parseIntLiteralM :: ParserM TricuAST -parseIntLiteralM = do - let intL = (\case LIntegerLiteral _ -> True; _ -> False) - tok <- satisfyM intL - if | LIntegerLiteral value <- tok -> - pure (SInt (fromIntegral value)) - | otherwise -> - fail "Unexpected token while parsing integer literal" - -parseStrLiteralM :: ParserM TricuAST -parseStrLiteralM = do - let strL = (\case LStringLiteral _ -> True; _ -> False) - tok <- satisfyM strL - if | LStringLiteral value <- tok -> - pure (SStr value) - | otherwise -> - fail "Unexpected token while parsing string literal" - -getIdentifier :: LToken -> String -getIdentifier (LIdentifier name) = name -getIdentifier _ = errorWithoutStackTrace "Expected identifier" - -handleParseError :: ParseErrorBundle [LToken] Void -> String -handleParseError bundle = - let errors = bundleErrors bundle - formattedErrors = map formatError (Data.List.NonEmpty.toList errors) - in unlines ("Parse error(s) encountered:" : formattedErrors) - -formatError :: ParseError [LToken] Void -> String -formatError (TrivialError offset msgUnexpected expected) = - let unexpectedMsg = case msgUnexpected of - Just x -> "unexpected token " ++ show x - Nothing -> "unexpected end of input" - expectedMsg = if null expected - then "" - else "expected " ++ show (Set.toList expected) - in "Parse error at offset " ++ show offset ++ ": " ++ unexpectedMsg ++ - if null expectedMsg then "" else " " ++ expectedMsg -formatError (FancyError offset _) = - "Parse error at offset " ++ show offset ++ ": unexpected FancyError" diff --git a/src/Research.hs b/src/Research.hs index 35633b1..e86007c 100644 --- a/src/Research.hs +++ b/src/Research.hs @@ -49,6 +49,7 @@ data LToken | LCloseBracket | LStringLiteral String | LIntegerLiteral Int + | LArrowLeft | LNewline deriving (Eq, Show, Ord) diff --git a/test/Spec.hs b/test/Spec.hs index 0f5d59d..5e7345e 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -111,6 +111,21 @@ lexer = testGroup "Lexer Tests" case (runParser tricuLexer "" "!result = 5") of Left _ -> return () Right _ -> assertFailure "Expected failure when trying to assign the value of !result" + + , testCase "Lex <| as arrow-left token" $ do + let input = "f <| g" + expect = Right [LIdentifier "f", LArrowLeft, LIdentifier "g"] + runParser tricuLexer "" input @?= expect + + , testCase "Lex <| without surrounding spaces" $ do + let input = "a<|b" + expect = Right [LIdentifier "a", LArrowLeft, LIdentifier "b"] + runParser tricuLexer "" input @?= expect + + , testCase "Lex $ remains legal identifier char" $ do + let input = "foo$bar = 1" + expect = Right [LIdentifier "foo$bar", LAssign, LIntegerLiteral 1] + runParser tricuLexer "" input @?= expect ] parser :: TestTree @@ -212,6 +227,30 @@ parser = testGroup "Parser Tests" let input = "(t) -- (t) -- (t)" expect = [TLeaf] parseTricu input @?= expect + + , testCase "Parse <| as low-precedence application" $ do + let input = "f x <| g y" + expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing)) + (SApp (SVar "g" Nothing) (SVar "y" Nothing)) + parseSingle input @?= expect + + , testCase "Parse chained <| as right-associative" $ do + let input = "f <| g <| h" + expect = SApp (SVar "f" Nothing) + (SApp (SVar "g" Nothing) (SVar "h" Nothing)) + parseSingle input @?= expect + + , testCase "Parse <| after newline inside parens" $ do + let input = "(f x <|\n g y)" + expect = SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing)) + (SApp (SVar "g" Nothing) (SVar "y" Nothing)) + parseSingle input @?= expect + + , testCase "Parse <| in lambda body" $ do + let input = "(x : f x <| g)" + expect = SLambda ["x"] (SApp (SApp (SVar "f" Nothing) (SVar "x" Nothing)) + (SVar "g" Nothing)) + parseSingle input @?= expect ] simpleEvaluation :: TestTree @@ -1571,32 +1610,32 @@ ioDriverTests = testGroup "IO driver tests" ] final @?= Fork (ofString "root-local") (ofString "root") - , testCase "local does not affect outer bind continuation" $ do - final <- runIOSourceWithEnv unsafePerms (ofString "root") $ - unlines - [ "main = io (bind" - , " (local (env : append env \"-local\") (pure \"x\"))" - , " (_ : bind ask (env : pure env)))" - ] - final @?= ofString "root" + , testCase "local does not affect outer bind continuation" $ do + final <- runIOSourceWithEnv unsafePerms (ofString "root") $ + unlines + [ "main = io (bind" + , " (local (env : append env \"-local\") (pure \"x\"))" + , " (_ : bind ask (env : pure env)))" + ] + final @?= ofString "root" - , testCase "local environment persists across inner binds" $ do - final <- runIOSourceWithEnv unsafePerms (ofString "root") $ - unlines - [ "main = io (local (env : append env \"-local\")" - , " (bind (pure t) (_ :" - , " bind ask (env : pure env))))" - ] - final @?= ofString "root-local" + , testCase "local environment persists across inner binds" $ do + final <- runIOSourceWithEnv unsafePerms (ofString "root") $ + unlines + [ "main = io (local (env : append env \"-local\")" + , " (bind (pure t) (_ :" + , " bind ask (env : pure env))))" + ] + final @?= ofString "root-local" - , testCase "local restores environment when scoped action returns error value" $ do - final <- runIOSourceWithEnv defaultPerms (ofString "root") $ - unlines - [ "main = io (bind" - , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))" - , " (_ : bind ask (env : pure env)))" - ] - final @?= ofString "root" + , testCase "local restores environment when scoped action returns error value" $ do + final <- runIOSourceWithEnv defaultPerms (ofString "root") $ + unlines + [ "main = io (bind" + , " (local (env : append env \"-local\") (readFile \"definitely-missing.txt\"))" + , " (_ : bind ask (env : pure env)))" + ] + final @?= ofString "root" -- State tests , testCase "get returns initial state" $ do @@ -1745,22 +1784,22 @@ ioDriverTests = testGroup "IO driver tests" ] final @?= ofString "awake" - , testCase "await waits for sleeping child and returns child value" $ do - (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ - unlines - [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :" - , " await h))" - ] - final @?= ofString "child done" - st @?= Leaf + , testCase "await waits for sleeping child and returns child value" $ do + (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ + unlines + [ "main = io (bind (fork (bind (sleep 1) (_ : pure \"child done\"))) (h :" + , " await h))" + ] + final @?= ofString "child done" + st @?= Leaf - , testCase "sleep inside bind resumes as unit" $ do - (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ - unlines - [ "main = io (bind (sleep 1) (_ : pure \"awake\"))" - ] - final @?= ofString "awake" - st @?= Leaf + , testCase "sleep inside bind resumes as unit" $ do + (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $ + unlines + [ "main = io (bind (sleep 1) (_ : pure \"awake\"))" + ] + final @?= ofString "awake" + st @?= Leaf , testCase "fork await returns child value" $ do (final, st) <- runIOSourceWith unsafePerms Leaf Leaf $