James/tricu
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Somewhat working lambdas

Browse Source 
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
This commit is contained in:
James Eversole
2024-12-27 12:27:00 -06:00
parent 7fca4d38e8
commit dbb5227fbc
5 changed files with 420 additions and 336 deletions
Download Patch File Download Diff File Expand all files Collapse all files

134
src/Eval.hs
View File

@ -2,121 +2,93 @@ module Eval where
import Parser import Parser
import Research 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)
evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T import Data.Map (Map)
import qualified Data.Map as Map
import Data.List (foldl')
import qualified Data.Set as Set
evalSingle :: Map String T -> SaplingAST -> Map String T
evalSingle env term = case term of evalSingle env term = case term of
SFunc name [] body -> SFunc name [] body ->
let result = evalAST env body let
in Map.insert name result env lineNoLambda = eliminateLambda body
SApp func arg -> result = evalAST env lineNoLambda
let result = apply (evalAST env func) (evalAST env arg) in Map.insert name result env
in Map.insert "__result" result env SLambda _ body ->
SVar name -> case Map.lookup name env of let result = evalAST env body
Just value -> Map.insert "__result" value env in Map.insert "__result" result env
Nothing -> error $ "Variable " ++ name ++ " not defined" SApp func arg ->
_ -> let result = apply (evalAST env func) (evalAST env arg)
let result = evalAST env term in Map.insert "__result" result env
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 :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env evalSapling env [] = env
evalSapling env [lastLine] = evalSapling env [lastLine] =
let let lastLineNoLambda = eliminateLambda lastLine
lastLineNoLambda = eliminateLambda lastLine
updatedEnv = evalSingle env lastLineNoLambda updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) = evalSapling env (line:rest) =
let let lineNoLambda = eliminateLambda line
lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest in evalSapling updatedEnv rest
evalAST :: Map String T -> SaplingAST -> T evalAST :: Map String T -> SaplingAST -> T
evalAST env term = case term of evalAST env term = case term of
SVar name -> SVar name -> case Map.lookup name env of
case Map.lookup name env of Just value -> value
Just value -> value Nothing -> error $ "Variable " ++ name ++ " not defined"
Nothing -> error $ "Variable " ++ name ++ " not defined"
TLeaf -> Leaf TLeaf -> Leaf
TStem t -> TStem t -> Stem (evalAST env t)
Stem (evalAST env t) TFork t1 t2 -> Fork (evalAST env t1) (evalAST env t2)
TFork t1 t2 -> SApp t1 t2 -> apply (evalAST env t1) (evalAST env t2)
Fork (evalAST env t1) (evalAST env t2)
SApp t1 t2 ->
apply (evalAST env t1) (evalAST env t2)
SStr str -> toString str SStr str -> toString str
SInt num -> toNumber num SInt num -> toNumber num
SList elems -> toList (map (evalAST Map.empty) elems) SList elems -> toList (map (evalAST Map.empty) elems)
SFunc name args body -> SFunc name args body ->
error $ "Unexpected function definition " ++ name error $ "Unexpected function definition " ++ name
++ " in evalAST; define via evalSingle." ++ " in evalAST; define via evalSingle."
SLambda {} -> SLambda {} -> error "Internal error: SLambda found in evalAST after elimination."
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"
eliminateLambda :: SaplingAST -> SaplingAST eliminateLambda :: SaplingAST -> SaplingAST
eliminateLambda (SLambda (v:vs) body) eliminateLambda (SLambda (v:vs) body)
| null vs = lambdaToT v (eliminateLambda body) | null vs = lambdaToT v (eliminateLambda body)
| otherwise = | otherwise = eliminateLambda (SLambda [v] (SLambda vs body))
eliminateLambda (SLambda [v] (SLambda vs body)) eliminateLambda (SApp f arg) = SApp (eliminateLambda f) (eliminateLambda arg)
eliminateLambda (SApp f arg) = eliminateLambda (TStem t) = TStem (eliminateLambda t)
SApp (eliminateLambda f) (eliminateLambda arg) eliminateLambda (TFork l r) = TFork (eliminateLambda l) (eliminateLambda r)
eliminateLambda (TStem t) = eliminateLambda (SList xs) = SList (map eliminateLambda xs)
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)
eliminateLambda other = other eliminateLambda other = other
lambdaToT :: String -> SaplingAST -> SaplingAST lambdaToT :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y) lambdaToT x (SVar y)
| x == y = tI | x == y = tI
lambdaToT x (SVar y) lambdaToT x (SVar y)
| x /= y = | x /= y = SApp tK (SVar y)
SApp tK (SVar y)
lambdaToT x t lambdaToT x t
| not (isFree x t) = | not (isFree x t) = SApp tK t
SApp tK t
lambdaToT x (SApp n u) lambdaToT x (SApp n u)
| not (isFree x (SApp n u)) = | not (isFree x (SApp n u)) = SApp tK (SApp (eliminateLambda n) (eliminateLambda 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 n u) =
SApp
(SApp tS (lambdaToT x (eliminateLambda n)))
(lambdaToT x (eliminateLambda u))
lambdaToT x (SApp f args) = lambdaToT x f
lambdaToT x body lambdaToT x body
| not (isFree x body) = | not (isFree x body) = SApp tK body
SApp tK body | otherwise = SApp (SApp tS (lambdaToT x body)) TLeaf
| otherwise =
SApp
(SApp tS (lambdaToT x body))
tLeaf
tLeaf :: SaplingAST freeVars :: SaplingAST -> Set.Set String
tLeaf = TLeaf
freeVars :: SaplingAST -> Set String
freeVars (SVar v) = Set.singleton v freeVars (SVar v) = Set.singleton v
freeVars (SInt _) = Set.empty freeVars (SInt _) = Set.empty
freeVars (SStr _) = Set.empty freeVars (SStr _) = Set.empty
freeVars (SList xs) = foldMap freeVars xs freeVars (SList xs) = foldMap freeVars xs
freeVars (SFunc _ _ b) = freeVars b
freeVars (SApp f arg) = freeVars f <> freeVars arg freeVars (SApp f arg) = freeVars f <> freeVars arg
freeVars TLeaf = Set.empty freeVars TLeaf = Set.empty
freeVars (SFunc _ _ b) = freeVars b
freeVars (TStem t) = freeVars t freeVars (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs 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) toAST (Fork a b) = TFork (toAST a) (toAST b)
tI :: SaplingAST tI :: SaplingAST
tI = toAST _I tI = SApp (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) TLeaf
tK :: SaplingAST tK :: SaplingAST
tK = toAST _K tK = SApp TLeaf TLeaf
tS :: SaplingAST 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"

5
src/Lexer.hs
View File

@ -7,6 +7,7 @@ import Data.Void
import qualified Data.Set as Set import qualified Data.Set as Set
type Lexer = Parsec Void String type Lexer = Parsec Void String
data LToken data LToken
= LKeywordT = LKeywordT
| LIdentifier String | LIdentifier String
@ -44,7 +45,7 @@ stringLiteral = do
if null content if null content
then fail "Empty string literals are not allowed" then fail "Empty string literals are not allowed"
else do else do
char '"' -- " char '"'
return (LStringLiteral content) return (LStringLiteral content)
assign :: Lexer LToken assign :: Lexer LToken
@ -92,5 +93,5 @@ saplingLexer = many (sc *> choice
lexSapling :: String -> [LToken] lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of 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 Right tokens -> tokens

3
src/Main.hs
View File

@ -11,3 +11,6 @@ import Text.Megaparsec (runParser)
main :: IO () main :: IO ()
main = repl Map.empty --(Map.fromList [("__result", Leaf)]) main = repl Map.empty --(Map.fromList [("__result", Leaf)])
runSapling :: String -> String
runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)

100
src/Parser.hs
View File

@ -1,10 +1,8 @@
module Parser where module Parser where
import Debug.Trace import Debug.Trace
import Lexer import Lexer
import Research hiding (toList) import Research hiding (toList)
import Control.Exception (throw) import Control.Exception (throw)
import Data.List.NonEmpty (toList) import Data.List.NonEmpty (toList)
import qualified Data.Set as Set import qualified Data.Set as Set
@ -14,17 +12,18 @@ import Text.Megaparsec.Char
import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle) import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken] type Parser = Parsec Void [LToken]
data SaplingAST data SaplingAST
= SVar String = SVar String
| SInt Int | SInt Int
| SStr String | SStr String
| SList [SaplingAST] | SList [SaplingAST]
| SFunc String [String] SaplingAST | SFunc String [String] SaplingAST
| SApp SaplingAST SaplingAST | SApp SaplingAST SaplingAST
| TLeaf | TLeaf
| TStem SaplingAST | TStem SaplingAST
| TFork SaplingAST SaplingAST | TFork SaplingAST SaplingAST
| SLambda [String] SaplingAST | SLambda [String] SaplingAST
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST] parseSapling :: String -> [SaplingAST]
@ -35,7 +34,7 @@ parseSapling input =
parseSingle :: String -> SaplingAST parseSingle :: String -> SaplingAST
parseSingle "" = error "Empty input provided to parseSingle" parseSingle "" = error "Empty input provided to parseSingle"
parseSingle input = case runParser parseExpression "" (lexSapling input) of parseSingle input = case runParser parseExpression "" (lexSapling input) of
Left err -> error $ handleParseError err Left err -> error $ handleParseError err
Right ast -> ast Right ast -> ast
scnParser :: Parser () scnParser :: Parser ()
@ -45,6 +44,7 @@ parseExpression :: Parser SaplingAST
parseExpression = choice parseExpression = choice
[ try parseFunction [ try parseFunction
, try parseLambda , try parseLambda
, try parseLambdaExpression
, try parseListLiteral , try parseListLiteral
, try parseApplication , try parseApplication
, try parseTreeTerm , try parseTreeTerm
@ -59,6 +59,19 @@ parseFunction = do
body <- parseExpression body <- parseExpression
return (SFunc name (map getIdentifier args) body) 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 :: Parser SaplingAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash) satisfy (== LBackslash)
@ -81,6 +94,7 @@ parseAtomicLambda = choice
, parseTreeLeaf , parseTreeLeaf
, parseLiteral , parseLiteral
, parseListLiteral , parseListLiteral
, try parseLambda
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
] ]
@ -92,22 +106,15 @@ parseApplication = do
parseLambdaApplication :: Parser SaplingAST parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication = do parseLambdaApplication = do
func <- parseAtomicLambda func <- parseAtomicLambda
args <- many parseAtomicLambda args <- many parseAtomicLambda
return $ foldl (\acc arg -> SApp acc arg) func args return $ foldl (\acc arg -> SApp acc arg) func args
isTreeTerm :: SaplingAST -> Bool isTreeTerm :: SaplingAST -> Bool
isTreeTerm TLeaf = True isTreeTerm TLeaf = True
isTreeTerm (TStem _) = True isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True isTreeTerm (TFork _ _) = True
isTreeTerm _ = False isTreeTerm _ = False
parseAtomicBase :: Parser SaplingAST
parseAtomicBase = choice
[ parseVar
, parseTreeLeaf
, parseGrouped
]
parseTreeLeaf :: Parser SaplingAST parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
@ -123,8 +130,8 @@ parseTreeTerm = do
pure $ foldl combine base rest pure $ foldl combine base rest
where where
combine acc next = case acc of combine acc next = case acc of
TLeaf -> TStem next TLeaf -> TStem next
TStem t -> TFork t next TStem t -> TFork t next
TFork _ _ -> TFork acc next TFork _ _ -> TFork acc next
parseTreeLeafOrParenthesized :: Parser SaplingAST parseTreeLeafOrParenthesized :: Parser SaplingAST
@ -147,7 +154,6 @@ parseAtomic = choice
, parseLiteral , parseLiteral
] ]
parseGrouped :: Parser SaplingAST parseGrouped :: Parser SaplingAST
parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
@ -190,8 +196,8 @@ parseSingleItem = do
token <- satisfy isListItem token <- satisfy isListItem
case token of case token of
LIdentifier name -> return (SVar name) LIdentifier name -> return (SVar name)
LKeywordT -> return TLeaf LKeywordT -> return TLeaf
_ -> fail "Unexpected token in list item" _ -> fail "Unexpected token in list item"
isListItem :: LToken -> Bool isListItem :: LToken -> Bool
isListItem (LIdentifier _) = True isListItem (LIdentifier _) = True
@ -216,24 +222,19 @@ parseStrLiteral = do
return (SStr value) return (SStr value)
-- Boolean Helpers -- Boolean Helpers
isKeywordT (LKeywordT) = True isKeywordT (LKeywordT) = True
isKeywordT _ = False isKeywordT _ = False
isIdentifier (LIdentifier _) = True
isIdentifier (LIdentifier _) = True isIdentifier _ = False
isIdentifier _ = False
isIntegerLiteral (LIntegerLiteral _) = True isIntegerLiteral (LIntegerLiteral _) = True
isIntegerLiteral _ = False isIntegerLiteral _ = False
isStringLiteral (LStringLiteral _) = True
isStringLiteral (LStringLiteral _) = True isStringLiteral _ = False
isStringLiteral _ = False isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral (LIntegerLiteral _) = True isLiteral _ = False
isLiteral (LStringLiteral _) = True isNewline (LNewline) = True
isLiteral _ = False isNewline _ = False
esNewline (LNewline) = True
isNewline _ = False
-- Error Handling -- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String handleParseError :: ParseErrorBundle [LToken] Void -> String
@ -246,9 +247,10 @@ handleParseError bundle =
showError :: ParseError [LToken] Void -> String showError :: ParseError [LToken] Void -> String
showError (TrivialError offset (Just (Tokens tokenStream)) expected) = showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
"Parse error at offset " ++ show offset ++ ": unexpected token " "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) = showError (FancyError offset fancy) =
"Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy)) "Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
showError (TrivialError offset Nothing expected) = showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset ++ ": expected one of " "Parse error at offset " ++ show offset ++ ": expected one of "
++ show (Set.toList expected) ++ show (Set.toList expected)

514
test/Spec.hs
View File

@ -5,237 +5,339 @@ import Lexer
import Parser import Parser
import Research import Research
import Control.Exception (evaluate, try, SomeException) import Control.Exception (evaluate, try, SomeException)
import qualified Data.Map as Map
import Test.Tasty import Test.Tasty
import Test.Tasty.HUnit import Test.Tasty.HUnit
import Test.Tasty.QuickCheck import Test.Tasty.QuickCheck
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
import qualified Data.Map as Map
import qualified Data.Set as Set
main :: IO () main :: IO ()
main = defaultMain tests main = defaultMain tests
runSapling :: String -> String
runSapling s = show $ result (evalSapling Map.empty $ parseSapling s)
tests :: TestTree tests :: TestTree
tests = testGroup "Sapling Tests" tests = testGroup "Sapling Tests"
[ lexerTests [ lexerTests
, parserTests , parserTests
, integrationTests , integrationTests
, evaluationTests , evaluationTests
, propertyTests , propertyTests
] , lambdaEvalTests
]
lexerTests :: TestTree lexerTests :: TestTree
lexerTests = testGroup "Lexer Tests" lexerTests = testGroup "Lexer Tests"
[ testCase "Lex simple identifiers" $ do [ testCase "Lex simple identifiers" $ do
let input = "x a b = a" let input = "x a b = a"
expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"] expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
runParser saplingLexer "" input @?= expect runParser saplingLexer "" input @?= expect
, testCase "Lex Tree Calculus terms" $ do , testCase "Lex Tree Calculus terms" $ do
let input = "t t t" let input = "t t t"
expect = Right [LKeywordT, LKeywordT, LKeywordT] expect = Right [LKeywordT, LKeywordT, LKeywordT]
runParser saplingLexer "" input @?= expect runParser saplingLexer "" input @?= expect
, testCase "Lex escaped characters in strings" $ do , testCase "Lex escaped characters in strings" $ do
let input = "\"hello\\nworld\"" let input = "\"hello\\nworld\""
expect = Right [LStringLiteral "hello\\nworld"] expect = Right [LStringLiteral "hello\\nworld"]
runParser saplingLexer "" input @?= expect runParser saplingLexer "" input @?= expect
, testCase "Lex mixed literals" $ do , testCase "Lex mixed literals" $ do
let input = "t \"string\" 42" let input = "t \"string\" 42"
expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42] expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
runParser saplingLexer "" input @?= expect runParser saplingLexer "" input @?= expect
, testCase "Lex invalid token" $ do , testCase "Lex invalid token" $ do
let input = "$invalid" let input = "$invalid"
case runParser saplingLexer "" input of case runParser saplingLexer "" input of
Left _ -> return () Left _ -> return ()
Right _ -> assertFailure "Expected lexer to fail on invalid token" Right _ -> assertFailure "Expected lexer to fail on invalid token"
, testCase "Drop trailing whitespace in definitions" $ do , testCase "Drop trailing whitespace in definitions" $ do
let input = "x = 5 " let input = "x = 5 "
expect = [LIdentifier "x",LAssign,LIntegerLiteral 5] expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
case (runParser saplingLexer "" input) of case (runParser saplingLexer "" input) of
Left _ -> assertFailure "Failed to lex input" Left _ -> assertFailure "Failed to lex input"
Right i -> i @?= expect Right i -> i @?= expect
, testCase "Error when using invalid characters in identifiers" $ do , testCase "Error when using invalid characters in identifiers" $ do
case (runParser saplingLexer "" "__result = 5") of case (runParser saplingLexer "" "__result = 5") of
Left _ -> return () Left _ -> return ()
Right _ -> assertFailure "Expected failure when trying to assign the value of __result" Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
] ]
parserTests :: TestTree parserTests :: TestTree
parserTests = testGroup "Parser Tests" parserTests = testGroup "Parser Tests"
[ testCase "Error when parsing incomplete definitions" $ do [ testCase "Error when parsing incomplete definitions" $ do
let input = lexSapling "x = " let input = lexSapling "x = "
case (runParser parseExpression "" input) of case (runParser parseExpression "" input) of
Left _ -> return () Left _ -> return ()
Right _ -> assertFailure "Expected failure on invalid input" Right _ -> assertFailure "Expected failure on invalid input"
, testCase "Error when assigning a value to T" $ do , testCase "Error when assigning a value to T" $ do
let input = lexSapling "t = x" let input = lexSapling "t = x"
case (runParser parseExpression "" input) of case (runParser parseExpression "" input) of
Left _ -> return () Left _ -> return ()
Right _ -> assertFailure "Expected failure when trying to assign the value of T" Right _ -> assertFailure "Expected failure when trying to assign the value of T"
, testCase "Error when parsing bodyless definitions with arguments" $ do , testCase "Parse function definitions" $ do
let input = lexSapling "x a b = " let input = "x = (\\a b c : a)"
case (runParser parseExpression "" input) of expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SLambda ["c"] (SVar "a"))))
Left _ -> return () parseSingle input @?= expect
Right _ -> assertFailure "Expected failure on invalid input" , testCase "Parse nested Tree Calculus terms" $ do
, testCase "Parse function definitions" $ do let input = "t (t t) t"
let input = "x a b c = a" expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
let expect = SFunc "x" ["a","b","c"] (SVar "a") parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse sequential Tree Calculus terms" $ do
, testCase "Parse nested Tree Calculus terms" $ do let input = "t t t"
let input = "t (t t) t" expect = SApp (SApp TLeaf TLeaf) TLeaf
let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse mixed list literals" $ do
, testCase "Parse sequential Tree Calculus terms" $ do let input = "[t (\"hello\") t]"
let input = "t t t" expect = SList [TLeaf, SStr "hello", TLeaf]
let expect = SApp (SApp TLeaf TLeaf) TLeaf parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse function with applications" $ do
, testCase "Parse mixed list literals" $ do let input = "f = (\\x : t x)"
let input = "[t (\"hello\") t]" expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SVar "x")))
let expect = SList [TLeaf, SStr "hello", TLeaf] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse nested lists" $ do
, testCase "Parse function with applications" $ do let input = "[t [(t t)]]"
let input = "f x = t x" expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x")) parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse complex parentheses" $ do
, testCase "Parse nested lists" $ do let input = "t (t t (t t))"
let input = "[t [(t t)]]" expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse empty list" $ do
, testCase "Parse complex parentheses" $ do let input = "[]"
let input = "t (t t (t t))" expect = SList []
let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf)) parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse multiple nested lists" $ do
, testCase "Parse empty list" $ do let input = "[[t t] [t (t t)]]"
let input = "[]" expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
let expect = SList [] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse whitespace variance" $ do
, testCase "Parse multiple nested lists" $ do let input1 = "[t t]"
let input = "[[t t] [t (t t)]]" let input2 = "[ t t ]"
let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]] expect = SList [TLeaf, TLeaf]
parseSingle input @?= expect parseSingle input1 @?= expect
, testCase "Parse whitespace variance" $ do parseSingle input2 @?= expect
let input1 = "[t t]" , testCase "Parse string in list" $ do
let input2 = "[ t t ]" let input = "[(\"hello\")]"
let expect = SList [TLeaf, TLeaf] expect = SList [SStr "hello"]
parseSingle input1 @?= expect parseSingle input @?= expect
parseSingle input2 @?= expect , testCase "Parse parentheses inside list" $ do
, testCase "Parse string in list" $ do let input = "[t (t t)]"
let input = "[(\"hello\")]" expect = SList [TLeaf,SApp TLeaf TLeaf]
let expect = SList [SStr "hello"] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse nested parentheses in function body" $ do
, testCase "Parse parentheses inside list" $ do let input = "f = (\\x : t (t (t t)))"
let input = "[t (t t)]" expect = SFunc "f" [] (SLambda ["x"] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))))
let expect = SList [TLeaf,SApp TLeaf TLeaf] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse lambda abstractions" $ do
, testCase "Parse nested parentheses in function body" $ do let input = "(\\a : a)"
let input = "f = t (t (t t))" expect = (SLambda ["a"] (SVar "a"))
let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf))) parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse multiple arguments to lambda abstractions" $ do
, testCase "Parse lambda abstractions" $ do let input = "x = (\\a b : a)"
let input = "(\\a : a)" expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
let expect = (SLambda ["a"] (SVar "a")) parseSingle input @?= expect
parseSingle input @?= expect , testCase "Grouping T terms with parentheses in function application" $ do
, testCase "Parse multiple arguments to lambda abstractions" $ do let input = "x = (\\a : a)\nx (t)"
let input = "x = (\\a b : a)" expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a"))) parseSapling input @?= expect
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
]
integrationTests :: TestTree integrationTests :: TestTree
integrationTests = testGroup "Integration Tests" integrationTests = testGroup "Integration Tests"
[ testCase "Combine lexer and parser" $ do [ testCase "Combine lexer and parser" $ do
let input = "x = t t t" let input = "x = t t t"
let expect = SFunc "x" [] (SApp (SApp TLeaf TLeaf) TLeaf) expect = SApp (SVar "x") (SApp (SApp TLeaf TLeaf) TLeaf)
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Complex Tree Calculus expression" $ do , testCase "Complex Tree Calculus expression" $ do
let input = "t (t t t) t" let input = "t (t t t) t"
let expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf expect = SApp (SApp TLeaf (SApp (SApp TLeaf TLeaf) TLeaf)) TLeaf
parseSingle input @?= expect parseSingle input @?= expect
] ]
evaluationTests :: TestTree evaluationTests :: TestTree
evaluationTests = testGroup "Evaluation Tests" evaluationTests = testGroup "Evaluation Tests"
[ testCase "Evaluate single Leaf" $ do [ testCase "Evaluate single Leaf" $ do
let input = "t" let input = "t"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Leaf (result $ evalSingle Map.empty ast) @?= Leaf
, testCase "Evaluate single Stem" $ do , testCase "Evaluate single Stem" $ do
let input = "t t" let input = "t t"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Stem Leaf (result $ evalSingle Map.empty ast) @?= Stem Leaf
, testCase "Evaluate single Fork" $ do , testCase "Evaluate single Fork" $ do
let input = "t t t" let input = "t t t"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf (result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
, testCase "Evaluate nested Fork and Stem" $ do , testCase "Evaluate nested Fork and Stem" $ do
let input = "t (t t) t" let input = "t (t t) t"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf (result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
, testCase "Evaluate `not` function" $ do , testCase "Evaluate `not` function" $ do
let input = "t (t (t t) (t t t)) t" let input = "t (t (t t) (t t t)) t"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= (result $ evalSingle Map.empty ast) @?=
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Environment updates with definitions" $ do , testCase "Environment updates with definitions" $ do
let input = "x = t\ny = x" let input = "x = t\ny = x"
let env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
Map.lookup "x" env @?= Just Leaf Map.lookup "x" env @?= Just Leaf
Map.lookup "y" env @?= Just Leaf Map.lookup "y" env @?= Just Leaf
, testCase "Variable substitution" $ do , testCase "Variable substitution" $ do
let input = "x = t t\ny = t x\ny" let input = "x = t t\ny = t x\ny"
let env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
(result env) @?= Stem (Stem Leaf) (result env) @?= Stem (Stem Leaf)
, testCase "Multiline input evaluation" $ do , testCase "Multiline input evaluation" $ do
let input = "x = t\ny = t t\nx" let input = "x = t\ny = t t\nx"
let env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
(result env) @?= Leaf (result env) @?= Leaf
, testCase "Evaluate string literal" $ do , testCase "Evaluate string literal" $ do
let input = "\"hello\"" let input = "\"hello\""
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toString "hello" (result $ evalSingle Map.empty ast) @?= toString "hello"
, testCase "Evaluate list literal" $ do , testCase "Evaluate list literal" $ do
let input = "[t (t t)]" let input = "[t (t t)]"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf] (result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
, testCase "Evaluate empty list" $ do , testCase "Evaluate empty list" $ do
let input = "[]" let input = "[]"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toList [] (result $ evalSingle Map.empty ast) @?= toList []
, testCase "Evaluate variable dependency chain" $ do , testCase "Evaluate variable dependency chain" $ do
let input = "x = t (t t)\n \ let input = "x = t (t t)\n \
\ y = x\n \ \ y = x\n \
\ z = y\n \ \ z = y\n \
\ variablewithamuchlongername = z\n \ \ variablewithamuchlongername = z\n \
\ variablewithamuchlongername" \ variablewithamuchlongername"
let env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
(result env) @?= (Stem (Stem Leaf)) (result env) @?= (Stem (Stem Leaf))
, testCase "Evaluate variable shadowing" $ do , testCase "Evaluate variable shadowing" $ do
let input = "x = t t\nx = t\nx" let input = "x = t t\nx = t\nx"
let env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
(result env) @?= Leaf (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 "Apply identity to Boolean Not" $ do , testCase "Apply identity to Boolean Not" $ do
let not = "(t (t (t t) (t t t)) t)" let not = "(t (t (t t) (t t t)) t)"
input = "x = (\\a : a)\nx " ++ not let input = "x = (\\a : a)\nx " ++ not
env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
, testCase "Constant function matches" $ do , testCase "Constant function matches" $ do
let input = "k = (\\a b : a)\nk (t t) t" let input = "k = (\\a b : a)\nk (t t) t"
env = evalSapling Map.empty (parseSapling input) env = evalSapling Map.empty (parseSapling input)
result env @?= Stem Leaf 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 :: TestTree
propertyTests = testGroup "Property Tests" propertyTests = testGroup "Property Tests"
[ testProperty "Lexing and parsing round-trip" $ \input -> [ testProperty "Lexing and parsing round-trip" $ \input ->
case runParser saplingLexer "" input of case runParser saplingLexer "" input of
Left _ -> property True Left _ -> property True
Right tokens -> case runParser parseExpression "" tokens of Right tokens -> case runParser parseExpression "" tokens of
Left _ -> property True Left _ -> property True
Right ast -> parseSingle input === ast 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)"
]