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

Stop using lists to represent args

Browse Source
This commit is contained in:
James Eversole 2024-12-27 08:17:06 -06:00
parent c5f1ccc4dc
commit 7fca4d38e8
7 changed files with 399 additions and 299 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -11,3 +11,4 @@ dist*
*~ *~
.env .env
WD WD
*.hs.txt

1
sapling.cabal
View File

@ -18,6 +18,7 @@ executable sapling
src src
default-extensions: default-extensions:
ConstraintKinds ConstraintKinds
DataKinds
DeriveGeneric DeriveGeneric
FlexibleContexts FlexibleContexts
FlexibleInstances FlexibleInstances

166
src/Eval.hs
View File

@ -2,63 +2,139 @@ 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 qualified Data.Map as Map
import Data.Map (Map) import Data.Map (Map)
evalSingle :: Map String T -> SaplingAST -> Map String T evalSingle :: Map.Map String T -> SaplingAST -> Map.Map String T
evalSingle env TLeaf = Map.insert "__result" Leaf env evalSingle env term = case term of
evalSingle env (TStem t) = SFunc name [] body ->
let result = Stem (evalTreeCalculus env t) let result = evalAST env body
in Map.insert "__result" result env in Map.insert name result env
evalSingle env (TFork t1 t2) = SApp func arg ->
let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2) let result = apply (evalAST env func) (evalAST env arg)
in Map.insert "__result" result env in Map.insert "__result" result env
evalSingle env (SFunc name [] body) = SVar name -> case Map.lookup name env of
let value = evalTreeCalculus env body Just value -> Map.insert "__result" value env
in Map.insert name value env Nothing -> error $ "Variable " ++ name ++ " not defined"
evalSingle env (SVar name) = _ ->
case Map.lookup name env of let result = evalAST env term
Just value -> Map.insert "__result" value env in Map.insert "__result" result env
Nothing -> error $ "Variable " ++ name ++ " not defined"
evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) 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 updatedEnv = evalSingle env lastLine let
lastLineNoLambda = eliminateLambda lastLine
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 updatedEnv = evalSingle env line let
lineNoLambda = eliminateLambda line
updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest in evalSapling updatedEnv rest
evalTreeCalculus :: Map.Map String T -> SaplingAST -> T evalAST :: Map String T -> SaplingAST -> T
evalTreeCalculus _ TLeaf = Leaf evalAST env term = case term of
evalTreeCalculus env (TStem t) = Stem (evalTreeCalculus env t) SVar name ->
evalTreeCalculus env (TFork t1 t2) = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2) case Map.lookup name env of
evalTreeCalculus env (SApp base []) = evalTreeCalculus env base Just value -> value
evalTreeCalculus env (SApp base args) = Nothing -> error $ "Variable " ++ name ++ " not defined"
let func = evalTreeCalculus env base TLeaf -> Leaf
argVals = map (evalTreeCalculus env) args TStem t ->
in foldl apply func argVals Stem (evalAST env t)
evalTreeCalculus env (SVar name) = TFork t1 t2 ->
case Map.lookup name env of Fork (evalAST env t1) (evalAST env t2)
Just value -> value SApp t1 t2 ->
Nothing -> error $ "Variable " ++ name ++ " not defined" apply (evalAST env t1) (evalAST env t2)
evalTreeCalculus _ (SStr str) = toString str SStr str -> toString str
evalTreeCalculus _ (SInt num) = toNumber num SInt num -> toNumber num
evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elems) SList elems -> toList (map (evalAST Map.empty) elems)
evalTreeCalculus _ (SFunc name args body) = SFunc name args body ->
error $ "Unexpected function definition " ++ name ++ " in \ error $ "Unexpected function definition " ++ name
\ evalTreeCalculus; functions should be evaluated to Tree Calculus \ ++ " in evalAST; define via evalSingle."
\ terms by evalSingle." SLambda {} ->
error "Internal error: SLambda found in evalAST after elimination."
result :: Map String T -> T result :: Map String T -> T
result r = case (Map.lookup "__result" r) of result r = case Map.lookup "__result" r of
Just a -> a Just a -> a
Nothing -> error "No __result field found in provided environment" Nothing -> error "No __result field found in provided environment"
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)
eliminateLambda other = other
lambdaToT :: String -> SaplingAST -> SaplingAST
lambdaToT x (SVar y)
| x == y = tI
lambdaToT x (SVar y)
| x /= y =
SApp tK (SVar y)
lambdaToT x 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
lambdaToT x body
| not (isFree x body) =
SApp tK body
| otherwise =
SApp
(SApp tS (lambdaToT x body))
tLeaf
tLeaf :: SaplingAST
tLeaf = TLeaf
freeVars :: SaplingAST -> 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 (TStem t) = freeVars t
freeVars (TFork l r) = freeVars l <> freeVars r
freeVars (SLambda vs b) = foldr Set.delete (freeVars b) vs
isFree :: String -> SaplingAST -> Bool
isFree x = Set.member x . freeVars
toAST :: T -> SaplingAST toAST :: T -> SaplingAST
toAST Leaf = TLeaf toAST Leaf = TLeaf
toAST (Stem a) = TStem (toAST a) 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 = toAST _I
tK :: SaplingAST
tK = toAST _K
tS :: SaplingAST
tS = toAST _S

10
src/Lexer.hs
View File

@ -13,6 +13,8 @@ data LToken
| LIntegerLiteral Int | LIntegerLiteral Int
| LStringLiteral String | LStringLiteral String
| LAssign | LAssign
| LColon
| LBackslash
| LOpenParen | LOpenParen
| LCloseParen | LCloseParen
| LOpenBracket | LOpenBracket
@ -48,6 +50,12 @@ stringLiteral = do
assign :: Lexer LToken assign :: Lexer LToken
assign = char '=' *> pure LAssign assign = char '=' *> pure LAssign
colon :: Lexer LToken
colon = char ':' *> pure LColon
backslash :: Lexer LToken
backslash = char '\\' *> pure LBackslash
openParen :: Lexer LToken openParen :: Lexer LToken
openParen = char '(' *> pure LOpenParen openParen = char '(' *> pure LOpenParen
@ -73,6 +81,8 @@ saplingLexer = many (sc *> choice
, try integerLiteral , try integerLiteral
, try stringLiteral , try stringLiteral
, assign , assign
, colon
, backslash
, openParen , openParen
, closeParen , closeParen
, openBracket , openBracket

2
src/Main.hs
View File

@ -6,7 +6,7 @@ import Parser
import REPL (repl) import REPL (repl)
import Research import Research
import Data.Map as Map import qualified Data.Map as Map
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
main :: IO () main :: IO ()

92
src/Parser.hs
View File

@ -1,5 +1,7 @@
module Parser where module Parser where
import Debug.Trace
import Lexer import Lexer
import Research hiding (toList) import Research hiding (toList)
@ -13,15 +15,16 @@ 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
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST] parseSapling :: String -> [SaplingAST]
@ -41,10 +44,11 @@ scnParser = skipMany (satisfy isNewline)
parseExpression :: Parser SaplingAST parseExpression :: Parser SaplingAST
parseExpression = choice parseExpression = choice
[ try parseFunction [ try parseFunction
, try parseLambda
, try parseListLiteral
, try parseApplication , try parseApplication
, parseTreeTerm , try parseTreeTerm
, parseLiteral , parseLiteral
, parseListLiteral
] ]
parseFunction :: Parser SaplingAST parseFunction :: Parser SaplingAST
@ -55,24 +59,54 @@ parseFunction = do
body <- parseExpression body <- parseExpression
return (SFunc name (map getIdentifier args) body) return (SFunc name (map getIdentifier args) body)
parseLambda :: Parser SaplingAST
parseLambda = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) $ do
satisfy (== LBackslash)
param <- satisfy isIdentifier
rest <- many (satisfy isIdentifier)
satisfy (== LColon)
body <- parseLambdaExpression
let nestedLambda = foldr (\v acc -> SLambda [v] acc) body (map getIdentifier rest)
return (SLambda [getIdentifier param] nestedLambda)
parseLambdaExpression :: Parser SaplingAST
parseLambdaExpression = choice
[ try parseLambdaApplication
, parseAtomicLambda
]
parseAtomicLambda :: Parser SaplingAST
parseAtomicLambda = choice
[ parseVar
, parseTreeLeaf
, parseLiteral
, parseListLiteral
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseLambdaExpression
]
parseApplication :: Parser SaplingAST parseApplication :: Parser SaplingAST
parseApplication = do parseApplication = do
func <- parseAtomicBase func <- parseAtomicBase
args <- many parseAtomicApplication args <- many parseAtomic
case func of return $ foldl (\acc arg -> SApp acc arg) func args
TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus"
_ -> return (SApp func args) parseLambdaApplication :: Parser SaplingAST
parseLambdaApplication = do
func <- parseAtomicLambda
args <- many parseAtomicLambda
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 :: Parser SaplingAST
parseAtomicBase = choice parseAtomicBase = choice
[ parseVar [ parseVar
, parseTreeLeaf , parseTreeLeaf
, parseGrouped
] ]
parseTreeLeaf :: Parser SaplingAST parseTreeLeaf :: Parser SaplingAST
@ -107,27 +141,15 @@ foldTree (x:y:rest) = TFork x (foldTree (y:rest))
parseAtomic :: Parser SaplingAST parseAtomic :: Parser SaplingAST
parseAtomic = choice parseAtomic = choice
[ parseVar [ parseVar
, parseTreeLeafOrParenthesized , parseTreeLeaf
, parseLiteral
, parseListLiteral , parseListLiteral
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression , parseGrouped
, parseLiteral
] ]
parseAtomicApplication :: Parser SaplingAST
parseAtomicApplication = do parseGrouped :: Parser SaplingAST
token <- anySingle parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
case token of
LAssign -> fail
"Unexpected `=` character in application context. \
\ This is usually caused by an incomplete definition such as: \
\ `function a b =`"
LIdentifier name -> return (SVar name)
LKeywordT -> return TLeaf
LIntegerLiteral value -> return (SInt value)
LStringLiteral value -> return (SStr value)
LOpenBracket -> parseListLiteral
LOpenParen -> between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
_ -> fail "Invalid token while parsing attempted function application"
parseLiteral :: Parser SaplingAST parseLiteral :: Parser SaplingAST
parseLiteral = choice parseLiteral = choice

426
test/Spec.hs
View File

@ -4,7 +4,6 @@ import Eval
import Lexer 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 qualified Data.Map as Map
import Test.Tasty import Test.Tasty
@ -17,235 +16,226 @@ main = defaultMain tests
tests :: TestTree tests :: TestTree
tests = testGroup "Sapling Tests" tests = testGroup "Sapling Tests"
[ lexerTests [ lexerTests
, parserTests , parserTests
, integrationTests , integrationTests
, evaluationTests , evaluationTests
, propertyTests , propertyTests
] ]
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"
let 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]
let expect = Right [LKeywordT, LKeywordT, LKeywordT] runParser saplingLexer "" input @?= expect
runParser saplingLexer "" input @?= expect , testCase "Lex escaped characters in strings" $ do
let input = "\"hello\\nworld\""
, testCase "Lex escaped characters in strings" $ do expect = Right [LStringLiteral "hello\\nworld"]
let input = "\"hello\\nworld\"" runParser saplingLexer "" input @?= expect
let expect = Right [LStringLiteral "hello\\nworld"] , testCase "Lex mixed literals" $ do
runParser saplingLexer "" input @?= expect let input = "t \"string\" 42"
expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
, testCase "Lex mixed literals" $ do runParser saplingLexer "" input @?= expect
let input = "t \"string\" 42" , testCase "Lex invalid token" $ do
let expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42] let input = "$invalid"
runParser saplingLexer "" input @?= expect case runParser saplingLexer "" input of
Left _ -> return ()
, testCase "Lex invalid token" $ do Right _ -> assertFailure "Expected lexer to fail on invalid token"
let input = "$invalid" , testCase "Drop trailing whitespace in definitions" $ do
case runParser saplingLexer "" input of let input = "x = 5 "
Left _ -> return () expect = [LIdentifier "x",LAssign,LIntegerLiteral 5]
Right _ -> assertFailure "Expected lexer to fail on invalid token" case (runParser saplingLexer "" input) of
Left _ -> assertFailure "Failed to lex input"
, testCase "Drop trailing whitespace in definitions" $ do Right i -> i @?= expect
let input = "x = 5 " , testCase "Error when using invalid characters in identifiers" $ do
let expect = [LIdentifier "x",LAssign,LIntegerLiteral 5] case (runParser saplingLexer "" "__result = 5") of
case (runParser saplingLexer "" input) of Left _ -> return ()
Left _ -> assertFailure "Failed to lex input" Right _ -> assertFailure "Expected failure when trying to assign the value of __result"
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"
]
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
let input = lexSapling "x a b = "
, testCase "Error when parsing bodyless definitions with arguments" $ do case (runParser parseExpression "" input) of
let input = lexSapling "x a b = " Left _ -> return ()
case (runParser parseExpression "" input) of Right _ -> assertFailure "Expected failure on invalid input"
Left _ -> return () , testCase "Parse function definitions" $ do
Right _ -> assertFailure "Expected failure on invalid input" let input = "x a b c = a"
let expect = SFunc "x" ["a","b","c"] (SVar "a")
, testCase "Parse function definitions" $ do parseSingle input @?= expect
let input = "x a b = a" , testCase "Parse nested Tree Calculus terms" $ do
let expect = SFunc "x" ["a", "b"] (SApp (SVar "a") []) let input = "t (t t) t"
parseSingle input @?= expect let expect = SApp (SApp TLeaf (SApp TLeaf TLeaf)) TLeaf
parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do , testCase "Parse sequential Tree Calculus terms" $ do
let input = "t (t t) t" let input = "t t t"
let expect = TFork (TStem TLeaf) TLeaf let expect = SApp (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" let expect = SList [TLeaf, SStr "hello", TLeaf]
let expect = TFork TLeaf TLeaf parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse function with applications" $ do
let input = "f x = t x"
, testCase "Parse mixed list literals" $ do let expect = SFunc "f" ["x"] (SApp TLeaf (SVar "x"))
let input = "[t (\"hello\") t]" parseSingle input @?= expect
let expect = SList [TLeaf, SStr "hello", TLeaf] , testCase "Parse nested lists" $ do
parseSingle input @?= expect let input = "[t [(t t)]]"
let expect = SList [TLeaf,SList [SApp TLeaf TLeaf]]
, testCase "Parse function with applications" $ do parseSingle input @?= expect
let input = "f x = t x" , testCase "Parse complex parentheses" $ do
let expect = SFunc "f" ["x"] (SApp TLeaf [SVar "x"]) let input = "t (t t (t t))"
parseSingle input @?= expect let expect = SApp TLeaf (SApp (SApp TLeaf TLeaf) (SApp TLeaf TLeaf))
parseSingle input @?= expect
, testCase "Parse nested lists" $ do , testCase "Parse empty list" $ do
let input = "[t [(t t)]]" let input = "[]"
let expect = SList [TLeaf, SList [TStem TLeaf]] let expect = SList []
parseSingle input @?= expect parseSingle input @?= expect
, testCase "Parse multiple nested lists" $ do
, testCase "Parse complex parentheses" $ do let input = "[[t t] [t (t t)]]"
let input = "t (t t (t t))" let expect = SList [SList [TLeaf,TLeaf],SList [TLeaf,SApp TLeaf TLeaf]]
let expect = TStem (TFork TLeaf (TStem TLeaf)) parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse whitespace variance" $ do
let input1 = "[t t]"
, testCase "Parse empty list" $ do let input2 = "[ t t ]"
let input = "[]" let expect = SList [TLeaf, TLeaf]
let expect = SList [] parseSingle input1 @?= expect
parseSingle input @?= expect parseSingle input2 @?= expect
, testCase "Parse string in list" $ do
, testCase "Parse multiple nested lists" $ do let input = "[(\"hello\")]"
let input = "[[t t] [t (t t)]]" let expect = SList [SStr "hello"]
let expect = SList [SList [TLeaf, TLeaf], SList [TLeaf, TStem TLeaf]] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse parentheses inside list" $ do
let input = "[t (t t)]"
, testCase "Parse whitespace variance" $ do let expect = SList [TLeaf,SApp TLeaf TLeaf]
let input1 = "[t t]" parseSingle input @?= expect
let input2 = "[ t t ]" , testCase "Parse nested parentheses in function body" $ do
let expect = SList [TLeaf, TLeaf] let input = "f = t (t (t t))"
parseSingle input1 @?= expect let expect = SFunc "f" [] (SApp TLeaf (SApp TLeaf (SApp TLeaf TLeaf)))
parseSingle input2 @?= expect parseSingle input @?= expect
, testCase "Parse lambda abstractions" $ do
, testCase "Parse string in list" $ do let input = "(\\a : a)"
let input = "[(\"hello\")]" let expect = (SLambda ["a"] (SVar "a"))
let expect = SList [SStr "hello"] parseSingle input @?= expect
parseSingle input @?= expect , testCase "Parse multiple arguments to lambda abstractions" $ do
let input = "x = (\\a b : a)"
, testCase "Parse parentheses inside list" $ do let expect = SFunc "x" [] (SLambda ["a"] (SLambda ["b"] (SVar "a")))
let input = "[t (t t)]" parseSingle input @?= expect
let expect = SList [TLeaf, TStem TLeaf] , testCase "Grouping T terms with parentheses in function application" $ do
parseSingle input @?= expect let input = "x = (\\a : a)\n" <> "x (t)"
expect = [SFunc "x" [] (SLambda ["a"] (SVar "a")),SApp (SVar "x") TLeaf]
, testCase "Parse nested parentheses in function body" $ do parseSapling input @?= expect
let input = "f = t (t (t t))" ]
let expect = SFunc "f" [] (TStem (TStem (TStem TLeaf)))
parseSingle 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" [] (TFork TLeaf TLeaf) let expect = SFunc "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
let expect = TFork (TFork 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
let input = "t t t"
, testCase "Evaluate single Fork" $ do let ast = parseSingle input
let input = "t t t" (result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf
let ast = parseSingle input , testCase "Evaluate nested Fork and Stem" $ do
(result $ evalSingle Map.empty ast) @?= Fork Leaf Leaf let input = "t (t t) t"
let ast = parseSingle input
, testCase "Evaluate nested Fork and Stem" $ do (result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf
let input = "t (t t) t" , testCase "Evaluate `not` function" $ do
let ast = parseSingle input let input = "t (t (t t) (t t t)) t"
(result $ evalSingle Map.empty ast) @?= Fork (Stem Leaf) Leaf let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?=
, testCase "Evaluate `not` function" $ do Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
let input = "t (t (t t) (t t t)) t)" , testCase "Environment updates with definitions" $ do
let ast = parseSingle input let input = "x = t\ny = x"
(result $ evalSingle Map.empty ast) @?= let env = evalSapling Map.empty (parseSapling input)
Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf Map.lookup "x" env @?= Just Leaf
Map.lookup "y" env @?= Just Leaf
, testCase "Environment updates with definitions" $ do , testCase "Variable substitution" $ do
let input = "x = t\ny = x" let input = "x = t t\ny = t x\ny"
let env = evalSapling Map.empty (parseSapling input) let env = evalSapling Map.empty (parseSapling input)
Map.lookup "x" env @?= Just Leaf (result env) @?= Stem (Stem Leaf)
Map.lookup "y" env @?= Just Leaf , testCase "Multiline input evaluation" $ do
let input = "x = t\ny = t t\nx"
, testCase "Variable substitution" $ do let env = evalSapling Map.empty (parseSapling input)
let input = "x = t t\ny = t x\ny" (result env) @?= Leaf
let env = evalSapling Map.empty (parseSapling input) , testCase "Evaluate string literal" $ do
(result env) @?= Stem (Stem Leaf) let input = "\"hello\""
let ast = parseSingle input
, testCase "Multiline input evaluation" $ do (result $ evalSingle Map.empty ast) @?= toString "hello"
let input = "x = t\ny = t t\nx" , testCase "Evaluate list literal" $ do
let env = evalSapling Map.empty (parseSapling input) let input = "[t (t t)]"
(result env) @?= Leaf let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf]
, testCase "Evaluate string literal" $ do , testCase "Evaluate empty list" $ do
let input = "\"hello\"" let input = "[]"
let ast = parseSingle input let ast = parseSingle input
(result $ evalSingle Map.empty ast) @?= toString "hello" (result $ evalSingle Map.empty ast) @?= toList []
, testCase "Evaluate variable dependency chain" $ do
, testCase "Evaluate list literal" $ do let input = "x = t (t t)\n \
let input = "[t (t t)]" \ y = x\n \
let ast = parseSingle input \ z = y\n \
(result $ evalSingle Map.empty ast) @?= toList [Leaf, Stem Leaf] \ variablewithamuchlongername = z\n \
\ variablewithamuchlongername"
, testCase "Evaluate empty list" $ do let env = evalSapling Map.empty (parseSapling input)
let input = "[]" (result env) @?= (Stem (Stem Leaf))
let ast = parseSingle input , testCase "Evaluate variable shadowing" $ do
(result $ evalSingle Map.empty ast) @?= toList [] let input = "x = t t\nx = t\nx"
let env = evalSapling Map.empty (parseSapling input)
, testCase "Evaluate variable dependency chain" $ do (result env) @?= Leaf
let input = "x = t\n \ , testCase "Lambda identity" $ do
\ y = t x\n \ let input = "(\\a : a)"
\ z = t y\n \ env = evalSapling Map.empty (parseSapling input)
\ variablewithamuchlongername = z\n \ result env @?= Fork (Stem (Stem Leaf)) (Stem Leaf)
\ variablewithamuchlongername" , testCase "Apply identity to Boolean Not" $ do
let env = evalSapling Map.empty (parseSapling input) let not = "(t (t (t t) (t t t)) t)"
(result env) @?= (Stem (Stem Leaf)) input = "x = (\\a : a)\nx " ++ not
env = evalSapling Map.empty (parseSapling input)
, testCase "Evaluate redefinition of variables" $ do result env @?= Fork (Fork (Stem Leaf) (Fork Leaf Leaf)) Leaf
let input = "x = t t\nx = t\nx" , testCase "Constant function matches" $ do
let env = evalSapling Map.empty (parseSapling input) let input = "k = (\\a b : a)\nk (t t) t"
(result env) @?= Leaf env = evalSapling Map.empty (parseSapling input)
] result env @?= Stem Leaf
]
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
] ]