321 lines
14 KiB
Haskell
321 lines
14 KiB
Haskell
module Main where
|
|
|
|
import Eval
|
|
import Lexer
|
|
import Library
|
|
import Parser
|
|
import Research
|
|
import Control.Exception (evaluate, try, SomeException)
|
|
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
|
|
, lambdaEvalTests
|
|
, propertyTests
|
|
]
|
|
|
|
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
|
|
case (runParser saplingLexer "" "__result = 5") of
|
|
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 "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"
|
|
expect = SFunc "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"
|
|
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) @?= ofString "hello"
|
|
, testCase "Evaluate list literal" $ do
|
|
let input = "[t (t t)]"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= ofList [Leaf, Stem Leaf]
|
|
, testCase "Evaluate empty list" $ do
|
|
let input = "[]"
|
|
let ast = parseSingle input
|
|
(result $ evalSingle Map.empty ast) @?= ofList []
|
|
, 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)"
|
|
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
|
|
, testCase "Boolean AND_ TF" $ do
|
|
let input = "and (t t) (t)"
|
|
env = evalSapling library (parseSapling input)
|
|
result env @?= Leaf
|
|
, testCase "Boolean AND_ FT" $ do
|
|
let input = "and (t) (t t)"
|
|
env = evalSapling library (parseSapling input)
|
|
result env @?= Leaf
|
|
, testCase "Boolean AND_ FF" $ do
|
|
let input = "and (t) (t)"
|
|
env = evalSapling library (parseSapling input)
|
|
result env @?= Leaf
|
|
, testCase "Boolean AND_ TT" $ do
|
|
let input = "and (t t) (t t)"
|
|
env = evalSapling library (parseSapling input)
|
|
result env @?= Stem Leaf
|
|
, testCase "Verifying Equality" $ do
|
|
let input = "equal (t t t) (t t t)"
|
|
env = evalSapling library (parseSapling input)
|
|
result env @?= Stem Leaf
|
|
]
|
|
|
|
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 @?= "Stem (Stem 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 @?= "Stem 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 "Nested lambda abstractions in the same expression" $ do
|
|
let input = "f = (\\x : (\\y : x y))\ng = (\\z : z)\nf g t"
|
|
runSapling input @?= "Leaf"
|
|
, testCase "Lambda with a string literal" $ do
|
|
let input = "f = (\\x : x)\nf \"hello\""
|
|
runSapling input @?= "Fork (Fork Leaf (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork Leaf (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) Leaf))))))) (Fork (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork (Stem Leaf) (Fork Leaf (Fork (Stem Leaf) (Fork (Stem Leaf) 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 (Fork (Stem Leaf) (Fork Leaf (Fork (Stem 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)"
|
|
]
|
|
|
|
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
|
|
]
|