commit c3c6646cb2b2cb8670e5fe927e774c506e701447
parent 5e574d2ca1985cef390e2b84b972d935c138be85
Author: James Eversole <james@eversole.co>
Date: Fri, 27 Dec 2024 12:27:00 -0600
Somewhat working lambdas
Architectural changes to lambda evaluation and parsing to allow
for correct expression evaluation. Contains several failing AI-generated
tests and we're still failing tests for erroring incomplete definitions
Diffstat:
| M | src/Eval.hs | | | 132 | ++++++++++++++++++++++++++++++++----------------------------------------------- |
| M | src/Lexer.hs | | | 5 | +++-- |
| M | src/Main.hs | | | 3 | +++ |
| M | src/Parser.hs | | | 100 | ++++++++++++++++++++++++++++++++++++++++--------------------------------------- |
| M | test/Spec.hs | | | 514 | +++++++++++++++++++++++++++++++++++++++++++++++-------------------------------- |
5 files changed, 419 insertions(+), 335 deletions(-)
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -2,121 +2,93 @@ module Eval where
import Parser
import Research
-import Data.Set (Set)
-import qualified Data.Set as Set
-import Data.List (foldl')
-import qualified Data.Map as Map
+
import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.List (foldl')
+import qualified Data.Set as Set
-evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T
+evalSingle :: Map String T -> SaplingAST -> Map String T
evalSingle env term = case term of
- SFunc name [] body ->
- let result = evalAST env body
- in Map.insert name result env
- SApp func arg ->
- let result = apply (evalAST env func) (evalAST env arg)
- in Map.insert "__result" result env
- SVar name -> case Map.lookup name env of
- Just value -> Map.insert "__result" value env
- Nothing -> error $ "Variable " ++ name ++ " not defined"
- _ ->
- let result = evalAST env term
- in Map.insert "__result" result env
+ SFunc name [] body ->
+ let
+ lineNoLambda = eliminateLambda body
+ result = evalAST env lineNoLambda
+ in Map.insert name result env
+ SLambda _ body ->
+ let result = evalAST env body
+ in Map.insert "__result" result env
+ SApp func arg ->
+ let result = apply (evalAST env func) (evalAST env arg)
+ in Map.insert "__result" result env
+ SVar name ->
+ case Map.lookup name env of
+ Just value -> Map.insert "__result" value env
+ Nothing -> error $ "Variable " ++ name ++ " not defined"
+ _ ->
+ let result = evalAST env term
+ in Map.insert "__result" result env
evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env
evalSapling env [lastLine] =
- let
- lastLineNoLambda = eliminateLambda lastLine
+ let lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
- let
- lineNoLambda = eliminateLambda line
+ let lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest
evalAST :: Map String T -> SaplingAST -> T
evalAST env term = case term of
- SVar name ->
- case Map.lookup name env of
- Just value -> value
- Nothing -> error $ "Variable " ++ name ++ " not defined"
+ SVar name -> case Map.lookup name env of
+ Just value -> value
+ Nothing -> error $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf
- TStem t ->
- Stem (evalAST env t)
- TFork t1 t2 ->
- Fork (evalAST env t1) (evalAST env t2)
- SApp t1 t2 ->
- apply (evalAST env t1) (evalAST env t2)
+ TStem t -> Stem (evalAST env t)
+ TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
+ SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
SStr str -> toString str
SInt num -> toNumber num
SList elems -> toList (map (evalAST Map.empty) elems)
SFunc name args body ->
error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle."
- SLambda {} ->
- error "Internal error: SLambda found in evalAST after elimination."
-
-result :: Map String T -> T
-result r = case Map.lookup "__result" r of
- Just a -> a
- Nothing -> error "No __result field found in provided environment"
-
+ SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
eliminateLambda :: SaplingAST -> SaplingAST
eliminateLambda (SLambda (v:vs) body)
- | null vs = lambdaToT v (eliminateLambda body)
- | otherwise =
- eliminateLambda (SLambda [v] (SLambda vs body))
-eliminateLambda (SApp f arg) =
- SApp (eliminateLambda f) (eliminateLambda arg)
-eliminateLambda (TStem t) =
- TStem (eliminateLambda t)
-eliminateLambda (TFork l r) =
- TFork (eliminateLambda l) (eliminateLambda r)
-eliminateLambda (SList xs) =
- SList (map eliminateLambda xs)
-eliminateLambda (SFunc n vs b) =
- SFunc n vs (eliminateLambda b)
+ | null vs = lambdaToT v (eliminateLambda body)
+ | otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
+eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
+eliminateLambda (TStem t) = TStem (eliminateLambda t)
+eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
+eliminateLambda (SList xs) = SList (map eliminateLambda xs)
eliminateLambda other = other
lambdaToT :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y)
- | x == y = tI
+ | x == y = tI
lambdaToT x (SVar y)
- | x /= y =
- SApp tK (SVar y)
+ | x /= y = SApp tK (SVar y)
lambdaToT x t
- | not (isFree x t) =
- SApp tK t
+ | not (isFree x t) = SApp tK t
lambdaToT x (SApp n u)
- | not (isFree x (SApp n u)) =
- SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
-lambdaToT x (SApp n u) =
- SApp
- (SApp tS (lambdaToT x (eliminateLambda n)))
- (lambdaToT x (eliminateLambda u))
-lambdaToT x (SApp f args) = lambdaToT x f
+ | not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda u))
+lambdaToT x (SApp n u) = SApp (SApp tS (lambdaToT x (eliminateLambda n))) (lambdaToT x (eliminateLambda u))
lambdaToT x body
- | not (isFree x body) =
- SApp tK body
- | otherwise =
- SApp
- (SApp tS (lambdaToT x body))
- tLeaf
-
-tLeaf :: SaplingAST
-tLeaf = TLeaf
+ | not (isFree x body) = SApp tK body
+ | otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
-freeVars :: SaplingAST -> Set String
+freeVars :: SaplingAST -> Set.Set String
freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty
freeVars (SList xs) = foldMap freeVars xs
-freeVars (SFunc _ _ b) = freeVars b
freeVars (SApp f arg) = freeVars f <> freeVars arg
freeVars TLeaf = Set.empty
+freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
@@ -130,11 +102,15 @@ toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
tI :: SaplingAST
-tI = toAST _I
+tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
tK :: SaplingAST
-tK = toAST _K
+tK = SApp TLeaf TLeaf
tS :: SaplingAST
-tS = toAST _S
+tS = SApp (SApp TLeaf (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf))) TLeaf
+result :: Map String T -> T
+result r = case Map.lookup "__result" r of
+ Just a -> a
+ Nothing -> error "No __result field found in provided environment"
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -7,6 +7,7 @@ import Data.Void
import qualified Data.Set as Set
type Lexer = Parsec Void String
+
data LToken
= LKeywordT
| LIdentifier String
@@ -44,7 +45,7 @@ stringLiteral = do
if null content
then fail "Empty string literals are not allowed"
else do
- char '"' -- "
+ char '"'
return (LStringLiteral content)
assign :: Lexer LToken
@@ -92,5 +93,5 @@ saplingLexer = many (sc *> choice
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of
- Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
+ Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens
diff --git a/src/Main.hs b/src/Main.hs
@@ -11,3 +11,6 @@ import Text.Megaparsec (runParser)
main :: IO ()
main = repl Map.empty --(Map.fromList [("__result", Leaf)])
+
+runSapling :: String -> String
+runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -1,10 +1,8 @@
module Parser where
import Debug.Trace
-
import Lexer
import Research hiding (toList)
-
import Control.Exception (throw)
import Data.List.NonEmpty (toList)
import qualified Data.Set as Set
@@ -14,17 +12,18 @@ import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken]
+
data SaplingAST
- = SVar String
- | SInt Int
- | SStr String
- | SList [SaplingAST]
- | SFunc String [String] SaplingAST
- | SApp SaplingAST SaplingAST
+ = SVar String
+ | SInt Int
+ | SStr String
+ | SList [SaplingAST]
+ | SFunc String [String] SaplingAST
+ | SApp SaplingAST SaplingAST
| TLeaf
- | TStem SaplingAST
- | TFork SaplingAST SaplingAST
- | SLambda [String] SaplingAST
+ | TStem SaplingAST
+ | TFork SaplingAST SaplingAST
+ | SLambda [String] SaplingAST
deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST]
@@ -35,7 +34,7 @@ parseSapling input =
parseSingle :: String -> SaplingAST
parseSingle "" = error "Empty input provided to parseSingle"
parseSingle input = case runParser parseExpression "" (lexSapling input) of
- Left err -> error $ handleParseError err
+ Left err -> error $ handleParseError err
Right ast -> ast
scnParser :: Parser ()
@@ -45,6 +44,7 @@ parseExpression :: Parser SaplingAST
parseExpression = choice
[ try parseFunction
, try parseLambda
+ , try parseLambdaExpression
, try parseListLiteral
, try parseApplication
, try parseTreeTerm
@@ -59,6 +59,19 @@ parseFunction = do
body <- parseExpression
return (SFunc name (map getIdentifier args) body)
+parseAtomicBase :: Parser SaplingAST
+parseAtomicBase = choice
+ [ try parseVarWithoutAssignment
+ , parseTreeLeaf
+ , parseGrouped
+ ]
+parseVarWithoutAssignment :: Parser SaplingAST
+parseVarWithoutAssignment = do
+ LIdentifier name <- satisfy isIdentifier
+ if (name == "t" || name == "__result")
+ then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
+ else notFollowedBy (satisfy (== LAssign)) *> return (SVar name)
+
parseLambda :: Parser SaplingAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
@@ -81,6 +94,7 @@ parseAtomicLambda = choice
, parseTreeLeaf
, parseLiteral
, parseListLiteral
+ , try parseLambda
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
]
@@ -92,22 +106,15 @@ parseApplication = do
parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication = do
- func <- parseAtomicLambda
- args <- many parseAtomicLambda
- return $ foldl (\acc arg -> SApp acc arg) func args
+ func <- parseAtomicLambda
+ args <- many parseAtomicLambda
+ return $ foldl (\acc arg -> SApp acc arg) func args
isTreeTerm :: SaplingAST -> Bool
-isTreeTerm TLeaf = True
-isTreeTerm (TStem _) = True
+isTreeTerm TLeaf = True
+isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True
-isTreeTerm _ = False
-
-parseAtomicBase :: Parser SaplingAST
-parseAtomicBase = choice
- [ parseVar
- , parseTreeLeaf
- , parseGrouped
- ]
+isTreeTerm _ = False
parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
@@ -123,8 +130,8 @@ parseTreeTerm = do
pure $ foldl combine base rest
where
combine acc next = case acc of
- TLeaf -> TStem next
- TStem t -> TFork t next
+ TLeaf -> TStem next
+ TStem t -> TFork t next
TFork _ _ -> TFork acc next
parseTreeLeafOrParenthesized :: Parser SaplingAST
@@ -147,7 +154,6 @@ parseAtomic = choice
, parseLiteral
]
-
parseGrouped :: Parser SaplingAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
@@ -190,8 +196,8 @@ parseSingleItem = do
token <- satisfy isListItem
case token of
LIdentifier name -> return (SVar name)
- LKeywordT -> return TLeaf
- _ -> fail "Unexpected token in list item"
+ LKeywordT -> return TLeaf
+ _ -> fail "Unexpected token in list item"
isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True
@@ -216,24 +222,19 @@ parseStrLiteral = do
return (SStr value)
-- Boolean Helpers
-isKeywordT (LKeywordT) = True
-isKeywordT _ = False
-
-isIdentifier (LIdentifier _) = True
-isIdentifier _ = False
-
+isKeywordT (LKeywordT) = True
+isKeywordT _ = False
+isIdentifier (LIdentifier _) = True
+isIdentifier _ = False
isIntegerLiteral (LIntegerLiteral _) = True
-isIntegerLiteral _ = False
-
-isStringLiteral (LStringLiteral _) = True
-isStringLiteral _ = False
-
-isLiteral (LIntegerLiteral _) = True
-isLiteral (LStringLiteral _) = True
-isLiteral _ = False
-
-esNewline (LNewline) = True
-isNewline _ = False
+isIntegerLiteral _ = False
+isStringLiteral (LStringLiteral _) = True
+isStringLiteral _ = False
+isLiteral (LIntegerLiteral _) = True
+isLiteral (LStringLiteral _) = True
+isLiteral _ = False
+isNewline (LNewline) = True
+isNewline _ = False
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String
@@ -246,9 +247,10 @@ handleParseError bundle =
showError :: ParseError [LToken] Void -> String
showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
"Parse error at offset " ++ show offset ++ ": unexpected token "
- ++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
+ ++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
showError (FancyError offset fancy) =
"Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset ++ ": expected one of "
- ++ show (Set.toList expected)
+ ++ show (Set.toList expected)
+
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -5,237 +5,339 @@ import Lexer
import Parser
import Research
import Control.Exception (evaluate, try, SomeException)
-import qualified Data.Map as Map
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Text.Megaparsec (runParser)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
main :: IO ()
main = defaultMain tests
+runSapling :: String -> String
+runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
+
tests :: TestTree
tests = testGroup "Sapling Tests"
- [ lexerTests
- , parserTests
- , integrationTests
- , evaluationTests
- , propertyTests
- ]
+ [ lexerTests
+ , parserTests
+ , integrationTests
+ , evaluationTests
+ , propertyTests
+ , lambdaEvalTests
+ ]
lexerTests :: TestTree
lexerTests = testGroup "Lexer Tests"
- [ testCase "Lex simple identifiers" $ do
- let input = "x a b = a"
- expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
- runParser saplingLexer "" input @?= expect
- , testCase "Lex Tree Calculus terms" $ do
- let input = "t t t"
- expect = Right [LKeywordT, LKeywordT, LKeywordT]
- runParser saplingLexer "" input @?= expect
- , testCase "Lex escaped characters in strings" $ do
- let input = "\"hello\\nworld\""
- expect = Right [LStringLiteral "hello\\nworld"]
- runParser saplingLexer "" input @?= expect
- , testCase "Lex mixed literals" $ do
- let input = "t \"string\" 42"
- expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
- runParser saplingLexer "" input @?= expect
- , testCase "Lex invalid token" $ do
- let input = "$invalid"
- case runParser saplingLexer "" input of
- Left _ -> return ()
- Right _ -> assertFailure "Expected lexer to fail on invalid token"
- , testCase "Drop trailing whitespace in definitions" $ do
- let input = "x = 5 "
- expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
- case (runParser saplingLexer "" input) of
- Left _ -> assertFailure "Failed to lex input"
- Right i -> i @?= expect
- , testCase "Error when using invalid characters in identifiers" $ do
+ [ testCase "Lex simple identifiers" $ do
+ let input = "x a b = a"
+ expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
+ runParser saplingLexer "" input @?= expect
+ , testCase "Lex Tree Calculus terms" $ do
+ let input = "t t t"
+ expect = Right [LKeywordT, LKeywordT, LKeywordT]
+ runParser saplingLexer "" input @?= expect
+ , testCase "Lex escaped characters in strings" $ do
+ let input = "\"hello\\nworld\""
+ expect = Right [LStringLiteral "hello\\nworld"]
+ runParser saplingLexer "" input @?= expect
+ , testCase "Lex mixed literals" $ do
+ let input = "t \"string\" 42"
+ expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
+ runParser saplingLexer "" input @?= expect
+ , testCase "Lex invalid token" $ do
+ let input = "$invalid"
+ case runParser saplingLexer "" input of
+ Left _ -> return ()
+ Right _ -> assertFailure "Expected lexer to fail on invalid token"
+ , testCase "Drop trailing whitespace in definitions" $ do
+ let input = "x = 5 "
+ expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
+ case (runParser saplingLexer "" input) of
+ Left _ -> assertFailure "Failed to lex input"
+ Right i -> i @?= expect
+ , testCase "Error when using invalid characters in identifiers" $ do
case (runParser saplingLexer "" "__result = 5") of
- Left _ -> return ()
- Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
- ]
+ Left _ -> return ()
+ Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
+ ]
parserTests :: TestTree
parserTests = testGroup "Parser Tests"
- [ testCase "Error when parsing incomplete definitions" $ do
- let input = lexSapling "x = "
- case (runParser parseExpression "" input) of
- Left _ -> return ()
- Right _ -> assertFailure "Expected failure on invalid input"
- , testCase "Error when assigning a value to T" $ do
- let input = lexSapling "t = x"
- case (runParser parseExpression "" input) of
- Left _ -> return ()
- Right _ -> assertFailure "Expected failure when trying to assign the value of T"
- , testCase "Error when parsing bodyless definitions with arguments" $ do
- let input = lexSapling "x a b = "
- case (runParser parseExpression "" input) of
- Left _ -> return ()
- Right _ -> assertFailure "Expected failure on invalid input"
- , testCase "Parse function definitions" $ do
- let input = "x a b c = a"
- let expect = SFunc "x" ["a","b","c"] (SVar "a")
- parseSingle input @?= expect
- , testCase "Parse nested Tree Calculus terms" $ do
- let input = "t (t t) t"
- let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
- parseSingle input @?= expect
- , testCase "Parse sequential Tree Calculus terms" $ do
- let input = "t t t"
- let expect = SApp (SApp TLeaf TLeaf) TLeaf
- parseSingle input @?= expect
- , testCase "Parse mixed list literals" $ do
- let input = "[t (\"hello\") t]"
- let expect = SList [TLeaf, SStr "hello", TLeaf]
- parseSingle input @?= expect
- , testCase "Parse function with applications" $ do
- let input = "f x = t x"
- let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x"))
- parseSingle input @?= expect
- , testCase "Parse nested lists" $ do
- let input = "[t [(t t)]]"
- let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
- parseSingle input @?= expect
- , testCase "Parse complex parentheses" $ do
- let input = "t (t t (t t))"
- let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
- parseSingle input @?= expect
- , testCase "Parse empty list" $ do
- let input = "[]"
- let expect = SList []
- parseSingle input @?= expect
- , testCase "Parse multiple nested lists" $ do
- let input = "[[t t] [t (t t)]]"
- let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
- parseSingle input @?= expect
- , testCase "Parse whitespace variance" $ do
- let input1 = "[t t]"
- let input2 = "[ t t ]"
- let expect = SList [TLeaf, TLeaf]
- parseSingle input1 @?= expect
- parseSingle input2 @?= expect
- , testCase "Parse string in list" $ do
- let input = "[(\"hello\")]"
- let expect = SList [SStr "hello"]
- parseSingle input @?= expect
- , testCase "Parse parentheses inside list" $ do
- let input = "[t (t t)]"
- let expect = SList [TLeaf,SApp TLeaf TLeaf]
- parseSingle input @?= expect
- , testCase "Parse nested parentheses in function body" $ do
- let input = "f = t (t (t t))"
- let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))
- parseSingle input @?= expect
- , testCase "Parse lambda abstractions" $ do
- let input = "(\\a : a)"
- let expect = (SLambda ["a"] (SVar "a"))
- parseSingle input @?= expect
- , testCase "Parse multiple arguments to lambda abstractions" $ do
- let input = "x = (\\a b : a)"
- let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
- parseSingle input @?= expect
- , testCase "Grouping T terms with parentheses in function application" $ do
- let input = "x = (\\a : a)\n" <> "x (t)"
- expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
- parseSapling input @?= expect
- ]
+ [ testCase "Error when parsing incomplete definitions" $ do
+ let input = lexSapling "x = "
+ case (runParser parseExpression "" input) of
+ Left _ -> return ()
+ Right _ -> assertFailure "Expected failure on invalid input"
+ , testCase "Error when assigning a value to T" $ do
+ let input = lexSapling "t = x"
+ case (runParser parseExpression "" input) of
+ Left _ -> return ()
+ Right _ -> assertFailure "Expected failure when trying to assign the value of T"
+ , testCase "Parse function definitions" $ do
+ let input = "x = (\\a b c : a)"
+ expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
+ parseSingle input @?= expect
+ , testCase "Parse nested Tree Calculus terms" $ do
+ let input = "t (t t) t"
+ expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
+ parseSingle input @?= expect
+ , testCase "Parse sequential Tree Calculus terms" $ do
+ let input = "t t t"
+ expect = SApp (SApp TLeaf TLeaf) TLeaf
+ parseSingle input @?= expect
+ , testCase "Parse mixed list literals" $ do
+ let input = "[t (\"hello\") t]"
+ expect = SList [TLeaf, SStr "hello", TLeaf]
+ parseSingle input @?= expect
+ , testCase "Parse function with applications" $ do
+ let input = "f = (\\x : t x)"
+ expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
+ parseSingle input @?= expect
+ , testCase "Parse nested lists" $ do
+ let input = "[t [(t t)]]"
+ expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
+ parseSingle input @?= expect
+ , testCase "Parse complex parentheses" $ do
+ let input = "t (t t (t t))"
+ expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
+ parseSingle input @?= expect
+ , testCase "Parse empty list" $ do
+ let input = "[]"
+ expect = SList []
+ parseSingle input @?= expect
+ , testCase "Parse multiple nested lists" $ do
+ let input = "[[t t] [t (t t)]]"
+ expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
+ parseSingle input @?= expect
+ , testCase "Parse whitespace variance" $ do
+ let input1 = "[t t]"
+ let input2 = "[ t t ]"
+ expect = SList [TLeaf, TLeaf]
+ parseSingle input1 @?= expect
+ parseSingle input2 @?= expect
+ , testCase "Parse string in list" $ do
+ let input = "[(\"hello\")]"
+ expect = SList [SStr "hello"]
+ parseSingle input @?= expect
+ , testCase "Parse parentheses inside list" $ do
+ let input = "[t (t t)]"
+ expect = SList [TLeaf,SApp TLeaf TLeaf]
+ parseSingle input @?= expect
+ , testCase "Parse nested parentheses in function body" $ do
+ let input = "f = (\\x : t (t (t t)))"
+ expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
+ parseSingle input @?= expect
+ , testCase "Parse lambda abstractions" $ do
+ let input = "(\\a : a)"
+ expect = (SLambda ["a"] (SVar "a"))
+ parseSingle input @?= expect
+ , testCase "Parse multiple arguments to lambda abstractions" $ do
+ let input = "x = (\\a b : a)"
+ expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
+ parseSingle input @?= expect
+ , testCase "Grouping T terms with parentheses in function application" $ do
+ let input = "x = (\\a : a)\nx (t)"
+ expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
+ parseSapling input @?= expect
+ ]
integrationTests :: TestTree
integrationTests = testGroup "Integration Tests"
- [ testCase "Combine lexer and parser" $ do
- let input = "x = t t t"
- let expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf)
- parseSingle input @?= expect
- , testCase "Complex Tree Calculus expression" $ do
- let input = "t (t t t) t"
- let expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
- parseSingle input @?= expect
- ]
+ [ testCase "Combine lexer and parser" $ do
+ let input = "x = t t t"
+ expect = SApp (SVar "x") (SApp (SApp TLeaf TLeaf) TLeaf)
+ parseSingle input @?= expect
+ , testCase "Complex Tree Calculus expression" $ do
+ let input = "t (t t t) t"
+ expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
+ parseSingle input @?= expect
+ ]
evaluationTests :: TestTree
evaluationTests = testGroup "Evaluation Tests"
- [ testCase "Evaluate single Leaf" $ do
- let input = "t"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= Leaf
- , testCase "Evaluate single Stem" $ do
- let input = "t t"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= Stem Leaf
- , testCase "Evaluate single Fork" $ do
- let input = "t t t"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
- , testCase "Evaluate nested Fork and Stem" $ do
- let input = "t (t t) t"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
- , testCase "Evaluate `not` function" $ do
- let input = "t (t (t t) (t t t)) t"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?=
- Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
- , testCase "Environment updates with definitions" $ do
- let input = "x = t\ny = x"
- let env = evalSapling Map.empty (parseSapling input)
- Map.lookup "x" env @?= Just Leaf
- Map.lookup "y" env @?= Just Leaf
- , testCase "Variable substitution" $ do
- let input = "x = t t\ny = t x\ny"
- let env = evalSapling Map.empty (parseSapling input)
- (result env) @?= Stem (Stem Leaf)
- , testCase "Multiline input evaluation" $ do
- let input = "x = t\ny = t t\nx"
- let env = evalSapling Map.empty (parseSapling input)
- (result env) @?= Leaf
- , testCase "Evaluate string literal" $ do
- let input = "\"hello\""
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= toString "hello"
- , testCase "Evaluate list literal" $ do
- let input = "[t (t t)]"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
- , testCase "Evaluate empty list" $ do
- let input = "[]"
- let ast = parseSingle input
- (result $ evalSingle Map.empty ast) @?= toList []
- , testCase "Evaluate variable dependency chain" $ do
- let input = "x = t (t t)\n \
- \ y = x\n \
- \ z = y\n \
- \ variablewithamuchlongername = z\n \
- \ variablewithamuchlongername"
- let env = evalSapling Map.empty (parseSapling input)
- (result env) @?= (Stem (Stem Leaf))
- , testCase "Evaluate variable shadowing" $ do
- let input = "x = t t\nx = t\nx"
- let env = evalSapling Map.empty (parseSapling input)
- (result env) @?= Leaf
- , testCase "Lambda identity" $ do
- let input = "(\\a : a)"
- env = evalSapling Map.empty (parseSapling input)
- result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
+ [ testCase "Evaluate single Leaf" $ do
+ let input = "t"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= Leaf
+ , testCase "Evaluate single Stem" $ do
+ let input = "t t"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= Stem Leaf
+ , testCase "Evaluate single Fork" $ do
+ let input = "t t t"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
+ , testCase "Evaluate nested Fork and Stem" $ do
+ let input = "t (t t) t"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
+ , testCase "Evaluate `not` function" $ do
+ let input = "t (t (t t) (t t t)) t"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?=
+ Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
+ , testCase "Environment updates with definitions" $ do
+ let input = "x = t\ny = x"
+ env = evalSapling Map.empty (parseSapling input)
+ Map.lookup "x" env @?= Just Leaf
+ Map.lookup "y" env @?= Just Leaf
+ , testCase "Variable substitution" $ do
+ let input = "x = t t\ny = t x\ny"
+ env = evalSapling Map.empty (parseSapling input)
+ (result env) @?= Stem (Stem Leaf)
+ , testCase "Multiline input evaluation" $ do
+ let input = "x = t\ny = t t\nx"
+ env = evalSapling Map.empty (parseSapling input)
+ (result env) @?= Leaf
+ , testCase "Evaluate string literal" $ do
+ let input = "\"hello\""
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= toString "hello"
+ , testCase "Evaluate list literal" $ do
+ let input = "[t (t t)]"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
+ , testCase "Evaluate empty list" $ do
+ let input = "[]"
+ let ast = parseSingle input
+ (result $ evalSingle Map.empty ast) @?= toList []
+ , testCase "Evaluate variable dependency chain" $ do
+ let input = "x = t (t t)\n \
+ \ y = x\n \
+ \ z = y\n \
+ \ variablewithamuchlongername = z\n \
+ \ variablewithamuchlongername"
+ env = evalSapling Map.empty (parseSapling input)
+ (result env) @?= (Stem (Stem Leaf))
+ , testCase "Evaluate variable shadowing" $ do
+ let input = "x = t t\nx = t\nx"
+ env = evalSapling Map.empty (parseSapling input)
+ (result env) @?= Leaf
, testCase "Apply identity to Boolean Not" $ do
- let not = "(t (t (t t) (t t t)) t)"
- input = "x = (\\a : a)\nx " ++ not
- env = evalSapling Map.empty (parseSapling input)
- result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
+ let not = "(t (t (t t) (t t t)) t)"
+ let input = "x = (\\a : a)\nx " ++ not
+ env = evalSapling Map.empty (parseSapling input)
+ result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Constant function matches" $ do
- let input = "k = (\\a b : a)\nk (t t) t"
- env = evalSapling Map.empty (parseSapling input)
- result env @?= Stem Leaf
- ]
+ let input = "k = (\\a b : a)\nk (t t) t"
+ env = evalSapling Map.empty (parseSapling input)
+ result env @?= Stem Leaf
+ , testCase "Boolean AND_ TF" $ do
+ let input = "and (t t) (t)"
+ env = evalSapling boolEnv (parseSapling input)
+ result env @?= Leaf
+ , testCase "Boolean AND_ FT" $ do
+ let input = "and (t) (t t)"
+ env = evalSapling boolEnv (parseSapling input)
+ result env @?= Leaf
+ , testCase "Boolean AND_ FF" $ do
+ let input = "and (t) (t)"
+ env = evalSapling boolEnv (parseSapling input)
+ result env @?= Leaf
+ , testCase "Boolean AND_ TT" $ do
+ let input = "and (t t) (t t)"
+ env = evalSapling boolEnv (parseSapling input)
+ result env @?= Stem Leaf
+ , testCase "Verifying Equality" $ do
+ let input = "equal (t t t) (t t t)"
+ env = evalSapling boolEnv (parseSapling input)
+ result env @?= Stem Leaf
+ ]
+ where
+ boolEnv = evalSapling Map.empty $ parseSapling
+ "false = t\n \
+ \ true = t t\n \
+ \ falseL = (\\z : false)\n \
+ \ id = (\\a : a)\n \
+ \ triage = (\\a b c : (t (t a b) c))\n \
+ \ match_bool = (\\ot of : triage of (\\z : ot) t)\n \
+ \ and = match_bool id falseL\n \
+ \ fix = (\\m wait f : wait m (\\x : f (wait m x))) (\\x : x x) (\\a b c : (t (t a) (t t c) b))\n \
+ \ equal = fix ((\\self : triage (triage true (\\z : false) (\\z x : false)) (\\ax : triage false (self ax) (\\z x : false)) (\\ax ay : triage false (\\z : false) (\\bx by : and (self ax bx) (self ay by)))))\
+ \ "
+
propertyTests :: TestTree
propertyTests = testGroup "Property Tests"
- [ testProperty "Lexing and parsing round-trip" $ \input ->
- case runParser saplingLexer "" input of
- Left _ -> property True
- Right tokens -> case runParser parseExpression "" tokens of
- Left _ -> property True
- Right ast -> parseSingle input === ast
- ]
+ [ testProperty "Lexing and parsing round-trip" $ \input ->
+ case runParser saplingLexer "" input of
+ Left _ -> property True
+ Right tokens -> case runParser parseExpression "" tokens of
+ Left _ -> property True
+ Right ast -> parseSingle input === ast
+ ]
+
+lambdaEvalTests :: TestTree
+lambdaEvalTests = testGroup "Lambda Evaluation Tests"
+ [ testCase "Lambda Identity Function" $ do
+ let input = "id = (\\x : x)\nid t"
+ runSapling input @?= "Leaf"
+
+ , testCase "Lambda Constant Function (K combinator)" $ do
+ let input = "k = (\\x y : x)\nk t (t t)"
+ runSapling input @?= "Leaf"
+
+ , testCase "Lambda Application with Variable" $ do
+ let input = "id = (\\x : x)\nval = t t\nid val"
+ runSapling input @?= "Stem Leaf"
+
+ , testCase "Lambda Application with Multiple Arguments" $ do
+ let input = "apply = (\\f x y : f x y)\nk = (\\a b : a)\napply k t (t t)"
+ runSapling input @?= "Leaf"
+
+ , testCase "Nested Lambda Application" $ do
+ let input = "apply = (\\f x y : f x y)\nid = (\\x : x)\napply (\\f x : f x) id t"
+ runSapling input @?= "Leaf"
+
+ , testCase "Lambda with a complex body" $ do
+ let input = "f = (\\x : t (t x))\nf t"
+ runSapling input @?= "Stem (Stem Leaf)"
+
+ , testCase "Lambda returning a function" $ do
+ let input = "f = (\\x : (\\y : x))\ng = f t\ng (t t)"
+ runSapling input @?= "Leaf"
+
+ , testCase "Lambda with Shadowing" $ do
+ let input = "f = (\\x : (\\x : x))\nf t (t t)"
+ runSapling input @?= "Stem Leaf"
+
+ , testCase "Lambda returning another lambda" $ do
+ let input = "k = (\\x : (\\y : x))\nk_app = k t\nk_app (t t)"
+ runSapling input @?= "Leaf"
+
+ , testCase "Lambda with free variables" $ do
+ let input = "y = t t\nf = (\\x : y)\nf t"
+ runSapling input @?= "Stem Leaf"
+
+ , testCase "SKI Composition" $ do
+ let input = "s = (\\x y z : x z (y z))\nk = (\\x y : x)\ni = (\\x : x)\ncomp = s k i\ncomp t (t t)"
+ runSapling input @?= "Leaf"
+ , testCase "Lambda with multiple parameters and application" $ do
+ let input = "f = (\\a b c : t a b c)\nf t (t t) (t t t)"
+ runSapling input @?= "Fork (Fork Leaf Leaf) Leaf"
+
+ , testCase "Lambda with nested application in the body" $ do
+ let input = "f = (\\x : t (t (t x)))\nf t"
+ runSapling input @?= "Stem (Stem (Stem Leaf))"
+ , testCase "Lambda returning a function and applying it" $ do
+ let input = "f = (\\x : (\\y : t x y))\ng = f t\ng (t t)"
+ runSapling input @?= "Fork Leaf (Stem Leaf)"
+ , testCase "Lambda applying a variable" $ do
+ let input = "id = (\\x : x)\na = t t\nid a"
+ runSapling input @?= "Stem Leaf"
+ , testCase "Multiple lambda abstractions in the same expression" $ do
+ let input = "f = (\\x : (\\y : x y))\ng = (\\z : z)\nf g t"
+ runSapling input @?= "Stem Leaf"
+ , testCase "Lambda with a string literal" $ do
+ let input = "f = (\\x : x)\nf \"hello\""
+ runSapling input @?= "Fork (Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork (Stem Leaf) (Fork Leaf Leaf))) (Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) (Fork (Stem Leaf) (Fork Leaf Leaf)))"
+ , testCase "Lambda with an integer literal" $ do
+ let input = "f = (\\x : x)\nf 42"
+ runSapling input @?= "Fork (Leaf) (Fork (Stem Leaf) (Fork Leaf Leaf))"
+ , testCase "Lambda with a list literal" $ do
+ let input = "f = (\\x : x)\nf [t (t t)]"
+ runSapling input @?= "Fork Leaf (Fork (Stem Leaf) Leaf)"
+ ]
