commit 5e574d2ca1985cef390e2b84b972d935c138be85
parent 37be4aac0a98b54cb65a5eafe5e37c5c505e4875
Author: James Eversole <james@eversole.co>
Date: Fri, 27 Dec 2024 08:17:06 -0600
Stop using lists to represent args
Diffstat:
7 files changed, 400 insertions(+), 300 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -11,3 +11,4 @@ dist*
*~
.env
WD
+*.hs.txt
diff --git a/sapling.cabal b/sapling.cabal
@@ -18,6 +18,7 @@ executable sapling
src
default-extensions:
ConstraintKinds
+ DataKinds
DeriveGeneric
FlexibleContexts
FlexibleInstances
diff --git a/src/Eval.hs b/src/Eval.hs
@@ -2,63 +2,139 @@ 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)
-
-evalSingle :: Map String T -> SaplingAST -> Map String T
-evalSingle env TLeaf = Map.insert "__result" Leaf env
-evalSingle env (TStem t) =
- let result = Stem (evalTreeCalculus env t)
- in Map.insert "__result" result env
-evalSingle env (TFork t1 t2) =
- let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
- in Map.insert "__result" result env
-evalSingle env (SFunc name [] body) =
- let value = evalTreeCalculus env body
- in Map.insert name value env
-evalSingle env (SVar name) =
- case Map.lookup name env of
- Just value -> Map.insert "__result" value env
- Nothing -> error $ "Variable " ++ name ++ " not defined"
-evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) env
+import Data.Map (Map)
+
+evalSingle :: Map.Map String T -> SaplingAST -> Map.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
evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalSapling env [] = env
evalSapling env [lastLine] =
- let updatedEnv = evalSingle env lastLine
+ let
+ lastLineNoLambda = eliminateLambda lastLine
+ updatedEnv = evalSingle env lastLineNoLambda
in Map.insert "__result" (result updatedEnv) updatedEnv
evalSapling env (line:rest) =
- let updatedEnv = evalSingle env line
+ let
+ lineNoLambda = eliminateLambda line
+ updatedEnv = evalSingle env lineNoLambda
in evalSapling updatedEnv rest
-evalTreeCalculus :: Map.Map String T -> SaplingAST -> T
-evalTreeCalculus _ TLeaf = Leaf
-evalTreeCalculus env (TStem t) = Stem (evalTreeCalculus env t)
-evalTreeCalculus env (TFork t1 t2) = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
-evalTreeCalculus env (SApp base []) = evalTreeCalculus env base
-evalTreeCalculus env (SApp base args) =
- let func = evalTreeCalculus env base
- argVals = map (evalTreeCalculus env) args
- in foldl apply func argVals
-evalTreeCalculus env (SVar name) =
- case Map.lookup name env of
- Just value -> value
- Nothing -> error $ "Variable " ++ name ++ " not defined"
-evalTreeCalculus _ (SStr str) = toString str
-evalTreeCalculus _ (SInt num) = toNumber num
-evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elems)
-evalTreeCalculus _ (SFunc name args body) =
- error $ "Unexpected function definition " ++ name ++ " in \
- \ evalTreeCalculus; functions should be evaluated to Tree Calculus \
- \ terms by evalSingle."
+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"
+ 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)
+ 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"
+result r = case Map.lookup "__result" r of
+ Just a -> a
+ 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 Leaf = TLeaf
-toAST (Stem a) = TStem (toAST a)
+toAST Leaf = TLeaf
+toAST (Stem a) = TStem (toAST a)
toAST (Fork a b) = TFork (toAST a) (toAST b)
+
+tI :: SaplingAST
+tI = toAST _I
+
+tK :: SaplingAST
+tK = toAST _K
+
+tS :: SaplingAST
+tS = toAST _S
+
diff --git a/src/Lexer.hs b/src/Lexer.hs
@@ -13,6 +13,8 @@ data LToken
| LIntegerLiteral Int
| LStringLiteral String
| LAssign
+ | LColon
+ | LBackslash
| LOpenParen
| LCloseParen
| LOpenBracket
@@ -48,6 +50,12 @@ stringLiteral = do
assign :: Lexer LToken
assign = char '=' *> pure LAssign
+colon :: Lexer LToken
+colon = char ':' *> pure LColon
+
+backslash :: Lexer LToken
+backslash = char '\\' *> pure LBackslash
+
openParen :: Lexer LToken
openParen = char '(' *> pure LOpenParen
@@ -73,6 +81,8 @@ saplingLexer = many (sc *> choice
, try integerLiteral
, try stringLiteral
, assign
+ , colon
+ , backslash
, openParen
, closeParen
, openBracket
diff --git a/src/Main.hs b/src/Main.hs
@@ -6,7 +6,7 @@ import Parser
import REPL (repl)
import Research
-import Data.Map as Map
+import qualified Data.Map as Map
import Text.Megaparsec (runParser)
main :: IO ()
diff --git a/src/Parser.hs b/src/Parser.hs
@@ -1,5 +1,7 @@
module Parser where
+import Debug.Trace
+
import Lexer
import Research hiding (toList)
@@ -13,15 +15,16 @@ 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
+ | TStem SaplingAST
+ | TFork SaplingAST SaplingAST
+ | SLambda [String] SaplingAST
deriving (Show, Eq, Ord)
parseSapling :: String -> [SaplingAST]
@@ -41,10 +44,11 @@ scnParser = skipMany (satisfy isNewline)
parseExpression :: Parser SaplingAST
parseExpression = choice
[ try parseFunction
+ , try parseLambda
+ , try parseListLiteral
, try parseApplication
- , parseTreeTerm
+ , try parseTreeTerm
, parseLiteral
- , parseListLiteral
]
parseFunction :: Parser SaplingAST
@@ -55,24 +59,54 @@ parseFunction = do
body <- parseExpression
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 = do
func <- parseAtomicBase
- args <- many parseAtomicApplication
- case func of
- TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus"
- _ -> return (SApp func args)
+ args <- many parseAtomic
+ return $ foldl (\acc arg -> SApp acc arg) 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 TLeaf = True
-isTreeTerm (TStem _) = True
+isTreeTerm TLeaf = True
+isTreeTerm (TStem _) = True
isTreeTerm (TFork _ _) = True
-isTreeTerm _ = False
+isTreeTerm _ = False
parseAtomicBase :: Parser SaplingAST
parseAtomicBase = choice
[ parseVar
, parseTreeLeaf
+ , parseGrouped
]
parseTreeLeaf :: Parser SaplingAST
@@ -107,27 +141,15 @@ foldTree (x:y:rest) = TFork x (foldTree (y:rest))
parseAtomic :: Parser SaplingAST
parseAtomic = choice
[ parseVar
- , parseTreeLeafOrParenthesized
- , parseLiteral
+ , parseTreeLeaf
, parseListLiteral
- , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
+ , parseGrouped
+ , parseLiteral
]
-parseAtomicApplication :: Parser SaplingAST
-parseAtomicApplication = do
- token <- anySingle
- 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"
+
+parseGrouped :: Parser SaplingAST
+parseGrouped = between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
parseLiteral :: Parser SaplingAST
parseLiteral = choice
diff --git a/test/Spec.hs b/test/Spec.hs
@@ -4,7 +4,6 @@ import Eval
import Lexer
import Parser
import Research
-
import Control.Exception (evaluate, try, SomeException)
import qualified Data.Map as Map
import Test.Tasty
@@ -17,235 +16,226 @@ main = defaultMain tests
tests :: TestTree
tests = testGroup "Sapling Tests"
- [ lexerTests
- , parserTests
- , integrationTests
- , evaluationTests
- , propertyTests
- ]
+ [ lexerTests
+ , parserTests
+ , integrationTests
+ , evaluationTests
+ , propertyTests
+ ]
lexerTests :: TestTree
lexerTests = testGroup "Lexer Tests"
- [ testCase "Lex simple identifiers" $ do
- let input = "x a b = a"
- let 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"
- let expect = Right [LKeywordT, LKeywordT, LKeywordT]
- runParser saplingLexer "" input @?= expect
-
- , testCase "Lex escaped characters in strings" $ do
- let input = "\"hello\\nworld\""
- let expect = Right [LStringLiteral "hello\\nworld"]
- runParser saplingLexer "" input @?= expect
-
- , testCase "Lex mixed literals" $ do
- let input = "t \"string\" 42"
- let 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 "
- let 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"
- ]
+ [ 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 "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 = a"
- let expect = SFunc "x" ["a", "b"] (SApp (SVar "a") [])
- parseSingle input @?= expect
-
- , testCase "Parse nested Tree Calculus terms" $ do
- let input = "t (t t) t"
- let expect = TFork (TStem TLeaf) TLeaf
- parseSingle input @?= expect
-
- , testCase "Parse sequential Tree Calculus terms" $ do
- let input = "t t t"
- let expect = TFork 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 [TStem TLeaf]]
- parseSingle input @?= expect
-
- , testCase "Parse complex parentheses" $ do
- let input = "t (t t (t t))"
- let expect = TStem (TFork TLeaf (TStem 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, TStem 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, TStem TLeaf]
- parseSingle input @?= expect
-
- , testCase "Parse nested parentheses in function body" $ do
- let input = "f = t (t (t t))"
- let expect = SFunc "f" [] (TStem (TStem (TStem TLeaf)))
- parseSingle 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 "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
+ ]
integrationTests :: TestTree
integrationTests = testGroup "Integration Tests"
- [ testCase "Combine lexer and parser" $ do
- let input = "x = t t t"
- let expect = SFunc "x" [] (TFork TLeaf TLeaf)
- parseSingle input @?= expect
-
- , testCase "Complex Tree Calculus expression" $ do
- let input = "t (t t t) t"
- let expect = TFork (TFork TLeaf TLeaf) TLeaf
- parseSingle input @?= expect
- ]
+ [ 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
+ ]
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\n \
- \ y = t x\n \
- \ z = t y\n \
- \ variablewithamuchlongername = z\n \
- \ variablewithamuchlongername"
- let env = evalSapling Map.empty (parseSapling input)
- (result env) @?= (Stem (Stem Leaf))
-
- , testCase "Evaluate redefinition of variables" $ do
- let input = "x = t t\nx = t\nx"
- let env = evalSapling Map.empty (parseSapling input)
- (result env) @?= 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"
+ 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 "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
+ , 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
+ ]
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
+ ]
