Includes better error handling, additional tests, parsing and lexing
fixes to match the desired behavior defined by the new tests, and a very
basic REPL implementation.
This commit is contained in:
James Eversole 2024-12-20 11:38:09 -06:00
parent a61627f333
commit c16c48b22c
8 changed files with 234 additions and 136 deletions

View File

@ -1,7 +1,7 @@
cabal-version: 1.12 cabal-version: 1.12
name: sapling name: sapling
version: 0.1.0 version: 0.2.0
description: Tree Calculus experiment repository description: Tree Calculus experiment repository
author: James Eversole author: James Eversole
maintainer: james@eversole.co maintainer: james@eversole.co
@ -34,6 +34,7 @@ executable sapling
Eval Eval
Lexer Lexer
Parser Parser
REPL
Research Research
default-language: Haskell2010 default-language: Haskell2010
@ -54,4 +55,5 @@ test-suite sapling-tests
Eval Eval
Lexer Lexer
Parser Parser
REPL
Research Research

View File

@ -6,31 +6,31 @@ import Research
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Map (Map) import Data.Map (Map)
evalSapling :: Map String T -> SaplingAST -> Map String T evalSingle :: Map String T -> SaplingAST -> Map String T
evalSapling env TLeaf = Map.insert "__result" Leaf env evalSingle env TLeaf = Map.insert "__result" Leaf env
evalSapling env (TStem t) = evalSingle env (TStem t) =
let result = Stem (evalTreeCalculus env t) let result = Stem (evalTreeCalculus env t)
in Map.insert "__result" result env in Map.insert "__result" result env
evalSapling env (TFork t1 t2) = evalSingle env (TFork t1 t2) =
let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2) let result = Fork (evalTreeCalculus env t1) (evalTreeCalculus env t2)
in Map.insert "__result" result env in Map.insert "__result" result env
evalSapling env (SFunc name [] body) = evalSingle env (SFunc name [] body) =
let value = evalTreeCalculus env body let value = evalTreeCalculus env body
in Map.insert name value env in Map.insert name value env
evalSapling env (SVar name) = evalSingle env (SVar name) =
case Map.lookup name env of case Map.lookup name env of
Just value -> Map.insert "__result" value env Just value -> Map.insert "__result" value env
Nothing -> error $ "Variable " ++ name ++ " not defined" Nothing -> error $ "Variable " ++ name ++ " not defined"
evalSapling env ast = Map.insert "__result" (evalTreeCalculus env ast) env evalSingle env ast = Map.insert "__result" (evalTreeCalculus env ast) env
evalMulti :: Map String T -> [SaplingAST] -> Map String T evalSapling :: Map String T -> [SaplingAST] -> Map String T
evalMulti env [] = env evalSapling env [] = env
evalMulti env [lastLine] = evalSapling env [lastLine] =
let updatedEnv = evalSapling env lastLine let updatedEnv = evalSingle env lastLine
in Map.insert "__result" (result updatedEnv) updatedEnv in Map.insert "__result" (result updatedEnv) updatedEnv
evalMulti env (line:rest) = evalSapling env (line:rest) =
let updatedEnv = evalSapling env line let updatedEnv = evalSingle env line
in evalMulti updatedEnv rest in evalSapling updatedEnv rest
evalTreeCalculus :: Map.Map String T -> SaplingAST -> T evalTreeCalculus :: Map.Map String T -> SaplingAST -> T
evalTreeCalculus _ TLeaf = Leaf evalTreeCalculus _ TLeaf = Leaf
@ -51,7 +51,7 @@ evalTreeCalculus _ (SList elems) = toList (map (evalTreeCalculus Map.empty) elem
evalTreeCalculus _ (SFunc name args body) = evalTreeCalculus _ (SFunc name args body) =
error $ "Unexpected function definition " ++ name ++ " in \ error $ "Unexpected function definition " ++ name ++ " in \
\ evalTreeCalculus; functions should be evaluated to Tree Calculus \ \ evalTreeCalculus; functions should be evaluated to Tree Calculus \
\ terms by evalSapling." \ terms by evalSingle."
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

View File

@ -4,7 +4,9 @@ import Research
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Data.Void import Data.Void
import qualified Data.Set as Set
-- Lexer type and tokens
type Lexer = Parsec Void String type Lexer = Parsec Void String
data LToken data LToken
= LKeywordT = LKeywordT
@ -19,6 +21,7 @@ data LToken
| LNewline | LNewline
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
-- Lexical rules
keywordT :: Lexer LToken keywordT :: Lexer LToken
keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT keywordT = string "t" *> notFollowedBy alphaNumChar *> pure LKeywordT
@ -38,8 +41,11 @@ stringLiteral :: Lexer LToken
stringLiteral = do stringLiteral = do
char '"' char '"'
content <- many (noneOf ['"']) content <- many (noneOf ['"'])
char '"' --" if null content
return (LStringLiteral content) then fail "Empty string literals are not allowed"
else do
char '"' -- "
return (LStringLiteral content)
assign :: Lexer LToken assign :: Lexer LToken
assign = char '=' *> pure LAssign assign = char '=' *> pure LAssign
@ -59,13 +65,15 @@ closeBracket = char ']' *> pure LCloseBracket
lnewline :: Lexer LToken lnewline :: Lexer LToken
lnewline = char '\n' *> pure LNewline lnewline = char '\n' *> pure LNewline
-- Whitespace consumer
sc :: Lexer () sc :: Lexer ()
sc = skipMany (char ' ' <|> char '\t') sc = skipMany (char ' ' <|> char '\t')
-- Lexer definition
saplingLexer :: Lexer [LToken] saplingLexer :: Lexer [LToken]
saplingLexer = many (sc *> choice saplingLexer = many (sc *> choice
[ try keywordT [ try identifier
, try identifier , try keywordT
, try integerLiteral , try integerLiteral
, try stringLiteral , try stringLiteral
, assign , assign
@ -74,8 +82,10 @@ saplingLexer = many (sc *> choice
, openBracket , openBracket
, closeBracket , closeBracket
, lnewline , lnewline
]) <* eof ] <* sc) <* eof
-- Lexing function with enhanced error handling
lexSapling :: String -> [LToken]
lexSapling input = case runParser saplingLexer "" input of lexSapling input = case runParser saplingLexer "" input of
Left err -> error "Failed to lex input" Left err -> error $ "Lexical error:\n" ++ errorBundlePretty err
Right tokens -> tokens Right tokens -> tokens

View File

@ -3,14 +3,11 @@ module Main where
import Eval import Eval
import Lexer import Lexer
import Parser import Parser
import REPL (repl)
import Research import Research
import Data.Map as Map import Data.Map as Map
import Text.Megaparsec (runParser) import Text.Megaparsec (runParser)
main :: IO () main :: IO ()
main = putStr main = repl Map.empty --(Map.fromList [("__result", Leaf)])
$ show
$ result
$ evalMulti Map.empty (parseMulti
"false = t\nnot = t (t (t t) (t t t)) t\ntrue = not false\ntrue")

View File

@ -1,10 +1,15 @@
module Parser where module Parser where
import Lexer import Lexer
import Research import Research hiding (toList)
import Control.Exception (throw)
import Data.List.NonEmpty (toList)
import qualified Data.Set as Set
import Data.Void
import Text.Megaparsec import Text.Megaparsec
import Text.Megaparsec.Char import Text.Megaparsec.Char
import Data.Void import Text.Megaparsec.Error (errorBundlePretty, ParseErrorBundle)
type Parser = Parsec Void [LToken] type Parser = Parsec Void [LToken]
data SaplingAST data SaplingAST
@ -19,10 +24,15 @@ data SaplingAST
| TFork SaplingAST SaplingAST | TFork SaplingAST SaplingAST
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
parseSapling :: String -> SaplingAST parseSapling :: String -> [SaplingAST]
parseSapling "" = error "Empty input provided to parseSapling" parseSapling input =
parseSapling input = case runParser parseExpression "" (lexSapling input) of let nonEmptyLines = filter (not . null) (lines input)
Left err -> error "Failed to parse input" in map parseSingle nonEmptyLines
parseSingle :: String -> SaplingAST
parseSingle "" = error "Empty input provided to parseSingle"
parseSingle input = case runParser parseExpression "" (lexSapling input) of
Left err -> error $ handleParseError err
Right ast -> ast Right ast -> ast
scnParser :: Parser () scnParser :: Parser ()
@ -48,7 +58,7 @@ parseFunction = do
parseApplication :: Parser SaplingAST parseApplication :: Parser SaplingAST
parseApplication = do parseApplication = do
func <- parseAtomicBase func <- parseAtomicBase
args <- many parseAtomic args <- many parseAtomicApplication
case func of case func of
TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus" TLeaf | not (null args) && all isTreeTerm args -> fail "Defer to Tree Calculus"
_ -> return (SApp func args) _ -> return (SApp func args)
@ -66,7 +76,7 @@ parseAtomicBase = choice
] ]
parseTreeLeaf :: Parser SaplingAST parseTreeLeaf :: Parser SaplingAST
parseTreeLeaf = satisfy isKeywordT *> pure TLeaf parseTreeLeaf = satisfy isKeywordT *> notFollowedBy (satisfy (== LAssign)) *> pure TLeaf
getIdentifier :: LToken -> String getIdentifier :: LToken -> String
getIdentifier (LIdentifier name) = name getIdentifier (LIdentifier name) = name
@ -86,7 +96,7 @@ parseTreeTerm = do
parseTreeLeafOrParenthesized :: Parser SaplingAST parseTreeLeafOrParenthesized :: Parser SaplingAST
parseTreeLeafOrParenthesized = choice parseTreeLeafOrParenthesized = choice
[ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm [ between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseTreeTerm
, satisfy isKeywordT *> pure TLeaf , parseTreeLeaf
] ]
foldTree :: [SaplingAST] -> SaplingAST foldTree :: [SaplingAST] -> SaplingAST
@ -103,6 +113,22 @@ parseAtomic = choice
, between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression , between (satisfy (== LOpenParen)) (satisfy (== LCloseParen)) parseExpression
] ]
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"
parseLiteral :: Parser SaplingAST parseLiteral :: Parser SaplingAST
parseLiteral = choice parseLiteral = choice
[ parseIntLiteral [ parseIntLiteral
@ -125,21 +151,21 @@ parseListLiteral = do
parseListItem :: Parser SaplingAST parseListItem :: Parser SaplingAST
parseListItem = choice parseListItem = choice
[ parseGroupedItem -- Handle expressions inside parentheses [ parseGroupedItem
, parseListLiteral -- Allow nested lists , parseListLiteral
, parseSingleItem -- Handle single tokens like `t` or identifiers , parseSingleItem
] ]
parseGroupedItem :: Parser SaplingAST parseGroupedItem :: Parser SaplingAST
parseGroupedItem = do parseGroupedItem = do
satisfy (== LOpenParen) satisfy (== LOpenParen)
inner <- parseExpression inner <- parseExpression
satisfy (== LCloseParen) satisfy (== LCloseParen)
return inner return inner
parseSingleItem :: Parser SaplingAST parseSingleItem :: Parser SaplingAST
parseSingleItem = do 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
@ -151,9 +177,11 @@ isListItem LKeywordT = True
isListItem _ = False isListItem _ = False
parseVar :: Parser SaplingAST parseVar :: Parser SaplingAST
parseVar = do parseVar = do
LIdentifier name <- satisfy isIdentifier LIdentifier name <- satisfy isIdentifier
return (SVar name) if (name == "t" || name == "__result")
then fail $ "Reserved keyword: " ++ name ++ " cannot be assigned."
else return (SVar name)
parseIntLiteral :: Parser SaplingAST parseIntLiteral :: Parser SaplingAST
parseIntLiteral = do parseIntLiteral = do
@ -165,11 +193,6 @@ parseStrLiteral = do
LStringLiteral value <- satisfy isStringLiteral LStringLiteral value <- satisfy isStringLiteral
return (SStr value) return (SStr value)
parseMulti :: String -> [SaplingAST]
parseMulti input =
let nonEmptyLines = filter (not . null) (lines input)
in map parseSapling nonEmptyLines
-- Boolean Helpers -- Boolean Helpers
isKeywordT (LKeywordT) = True isKeywordT (LKeywordT) = True
isKeywordT _ = False isKeywordT _ = False
@ -183,5 +206,27 @@ isIntegerLiteral _ = False
isStringLiteral (LStringLiteral _) = True isStringLiteral (LStringLiteral _) = True
isStringLiteral _ = False isStringLiteral _ = False
isNewline (LNewline) = True isLiteral (LIntegerLiteral _) = True
isLiteral (LStringLiteral _) = True
isLiteral _ = False
esNewline (LNewline) = True
isNewline _ = False isNewline _ = False
-- Error Handling
handleParseError :: ParseErrorBundle [LToken] Void -> String
handleParseError bundle =
let errors = bundleErrors bundle
errorList = toList errors
formattedErrors = map showError errorList
in unlines ("Parse error(s) encountered:" : formattedErrors)
showError :: ParseError [LToken] Void -> String
showError (TrivialError offset (Just (Tokens tokenStream)) expected) =
"Parse error at offset " ++ show offset ++ ": unexpected token "
++ show tokenStream ++ ", expected one of " ++ show (Set.toList expected)
showError (FancyError offset fancy) =
"Parse error at offset " ++ show offset ++ ":\n " ++ unlines (map show (Set.toList fancy))
showError (TrivialError offset Nothing expected) =
"Parse error at offset " ++ show offset ++ ": expected one of "
++ show (Set.toList expected)

25
src/REPL.hs Normal file
View File

@ -0,0 +1,25 @@
module REPL where
import Eval
import Lexer
import Parser
import Research
import Control.Monad (void)
import qualified Data.Map as Map
import System.IO (hFlush, stdout)
repl :: Map.Map String T -> IO ()
repl env = do
putStr "sapling > "
hFlush stdout
input <- getLine
if input == "_:exit"
then putStrLn "Goodbye!"
else do
let clearEnv = Map.delete "__result" env
let newEnv = evalSingle clearEnv (parseSingle input)
case Map.lookup "__result" newEnv of
Just r -> putStrLn $ "sapling < " ++ show r
Nothing -> pure ()
repl newEnv

View File

@ -24,8 +24,8 @@ reduce expr =
step :: T -> T step :: T -> T
step (Fork left right) = reduce (apply (reduce left) (reduce right)) step (Fork left right) = reduce (apply (reduce left) (reduce right))
step (Stem inner) = Stem (reduce inner) step (Stem inner) = Stem (reduce inner)
step t = t step t = t
-- SKI Combinators -- SKI Combinators
_S :: T _S :: T
@ -54,20 +54,20 @@ toString str = toList (map toNumber (map fromEnum str))
ofString :: T -> String ofString :: T -> String
ofString tc = map (toEnum . ofNumber) (ofList tc) ofString tc = map (toEnum . ofNumber) (ofList tc)
toNumber :: Int -> T toNumber :: Int -> T
toNumber 0 = Leaf toNumber 0 = Leaf
toNumber n = toNumber n =
Fork Fork
(if odd n then Stem Leaf else Leaf) (if odd n then Stem Leaf else Leaf)
(toNumber (n `div` 2)) (toNumber (n `div` 2))
ofNumber :: T -> Int ofNumber :: T -> Int
ofNumber Leaf = 0 ofNumber Leaf = 0
ofNumber (Fork Leaf rest) = 2 * ofNumber rest ofNumber (Fork Leaf rest) = 2 * ofNumber rest
ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest ofNumber (Fork (Stem Leaf) rest) = 1 + 2 * ofNumber rest
ofNumber _ = error "Invalid Tree Calculus number" ofNumber _ = error "Invalid Tree Calculus number"
toList :: [T] -> T toList :: [T] -> T
toList [] = Leaf toList [] = Leaf
toList (x:xs) = Fork x (toList xs) toList (x:xs) = Fork x (toList xs)
@ -92,13 +92,13 @@ toAscii tree = go tree "" True
++ go right (prefix ++ (if isLast then " " else "| ")) True ++ go right (prefix ++ (if isLast then " " else "| ")) True
rules :: IO () rules :: IO ()
rules = putStr $ header rules = putStr $ header
++ (unlines $ tcRules) ++ (unlines $ tcRules)
++ (unlines $ haskellRules) ++ (unlines $ haskellRules)
++ footer ++ footer
where where
tcRules :: [String] tcRules :: [String]
tcRules = tcRules =
[ "| |" [ "| |"
, "| ┌--------- | Tree Calculus | ---------┐ |" , "| ┌--------- | Tree Calculus | ---------┐ |"
, "| | 1. t t a b -> a | |" , "| | 1. t t a b -> a | |"

View File

@ -28,195 +28,215 @@ 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 expected = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"] let expect = Right [LIdentifier "x", LIdentifier "a", LIdentifier "b", LAssign, LIdentifier "a"]
runParser saplingLexer "" input @?= expected 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"
let expected = Right [LKeywordT, LKeywordT, LKeywordT] let expect = Right [LKeywordT, LKeywordT, LKeywordT]
runParser saplingLexer "" input @?= expected runParser saplingLexer "" input @?= expect
, testCase "Handle invalid input" $ do
let input = "x = "
case runParser saplingLexer "" input of
Left _ -> return ()
Right _ -> assertFailure "Expected failure on invalid input"
, testCase "Lex escaped characters in strings" $ do , testCase "Lex escaped characters in strings" $ do
let input = "\"hello\\nworld\"" let input = "\"hello\\nworld\""
let expected = Right [LStringLiteral "hello\\nworld"] let expect = Right [LStringLiteral "hello\\nworld"]
runParser saplingLexer "" input @?= expected runParser saplingLexer "" input @?= expect
, testCase "Lex mixed literals" $ do , testCase "Lex mixed literals" $ do
let input = "t \"string\" 42" let input = "t \"string\" 42"
let expected = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42] let expect = Right [LKeywordT, LStringLiteral "string", LIntegerLiteral 42]
runParser saplingLexer "" input @?= expected 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
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"
] ]
parserTests :: TestTree parserTests :: TestTree
parserTests = testGroup "Parser Tests" parserTests = testGroup "Parser Tests"
[ testCase "Parse function definitions" $ do [ 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 input = "x a b = a"
let expected = SFunc "x" ["a", "b"] (SApp (SVar "a") []) let expect = SFunc "x" ["a", "b"] (SApp (SVar "a") [])
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse nested Tree Calculus terms" $ do , testCase "Parse nested Tree Calculus terms" $ do
let input = "t (t t) t" let input = "t (t t) t"
let expected = TFork (TStem TLeaf) TLeaf let expect = TFork (TStem TLeaf) TLeaf
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse sequential Tree Calculus terms" $ do , testCase "Parse sequential Tree Calculus terms" $ do
let input = "t t t" let input = "t t t"
let expected = TFork TLeaf TLeaf let expect = TFork TLeaf TLeaf
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse mixed list literals" $ do , testCase "Parse mixed list literals" $ do
-- You must put non-list literals in parentheses
let input = "[t (\"hello\") t]" let input = "[t (\"hello\") t]"
let expected = SList [TLeaf, SStr "hello", TLeaf] let expect = SList [TLeaf, SStr "hello", TLeaf]
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse function with applications" $ do , testCase "Parse function with applications" $ do
let input = "f x = t x" let input = "f x = t x"
let expected = SFunc "f" ["x"] (SApp TLeaf [SVar "x"]) let expect = SFunc "f" ["x"] (SApp TLeaf [SVar "x"])
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse nested lists" $ do , testCase "Parse nested lists" $ do
let input = "[t [(t t)]]" let input = "[t [(t t)]]"
let expected = SList [TLeaf, SList [TStem TLeaf]] let expect = SList [TLeaf, SList [TStem TLeaf]]
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse complex parentheses" $ do , testCase "Parse complex parentheses" $ do
let input = "t (t t (t t))" let input = "t (t t (t t))"
let expected = TStem (TFork TLeaf (TStem TLeaf)) let expect = TStem (TFork TLeaf (TStem TLeaf))
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse empty list" $ do , testCase "Parse empty list" $ do
let input = "[]" let input = "[]"
let expected = SList [] let expect = SList []
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse multiple nested lists" $ do , testCase "Parse multiple nested lists" $ do
let input = "[[t t] [t (t t)]]" let input = "[[t t] [t (t t)]]"
let expected = SList [SList [TLeaf, TLeaf], SList [TLeaf, TStem TLeaf]] let expect = SList [SList [TLeaf, TLeaf], SList [TLeaf, TStem TLeaf]]
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse whitespace variance" $ do , testCase "Parse whitespace variance" $ do
let input1 = "[t t]" let input1 = "[t t]"
let input2 = "[ t t ]" let input2 = "[ t t ]"
let expected = SList [TLeaf, TLeaf] let expect = SList [TLeaf, TLeaf]
parseSapling input1 @?= expected parseSingle input1 @?= expect
parseSapling input2 @?= expected parseSingle input2 @?= expect
, testCase "Parse string in list" $ do , testCase "Parse string in list" $ do
let input = "[(\"hello\")]" let input = "[(\"hello\")]"
let expected = SList [SStr "hello"] let expect = SList [SStr "hello"]
parseSapling input @?= expected parseSingle input @?= expect
, testCase "Parse parentheses inside list" $ do , testCase "Parse parentheses inside list" $ do
let input = "[t (t t)]" let input = "[t (t t)]"
let expected = SList [TLeaf, TStem TLeaf] let expect = SList [TLeaf, TStem TLeaf]
parseSapling input @?= expected parseSingle input @?= expect
-- Do I want to allow multi-line indentation-sensitive syntax?
-- Probably not.
--, testCase "Parse multi-line function definition" $ do
-- let input = "f x y =\n t t"
-- let expected = SFunc "f" ["x", "y"] (TStem TLeaf)
-- parseSapling input @?= expected
, testCase "Parse nested parentheses in function body" $ do , testCase "Parse nested parentheses in function body" $ do
let input = "f = t (t (t t))" let input = "f = t (t (t t))"
let expected = SFunc "f" [] (TStem (TStem (TStem TLeaf))) let expect = SFunc "f" [] (TStem (TStem (TStem TLeaf)))
parseSapling input @?= expected 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 expected = SFunc "x" [] (TFork TLeaf TLeaf) let expect = SFunc "x" [] (TFork TLeaf TLeaf)
parseSapling input @?= expected 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 expected = TFork (TFork TLeaf TLeaf) TLeaf let expect = TFork (TFork TLeaf TLeaf) TLeaf
parseSapling input @?= expected 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = evalMulti Map.empty (parseMulti input) let 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 = evalMulti Map.empty (parseMulti input) let 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 = evalMulti Map.empty (parseMulti input) let 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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 = parseSapling input let ast = parseSingle input
(result $ evalSapling 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\ny = t x\nz = t y\nz" let input = "x = t\n \
let env = evalMulti Map.empty (parseMulti input) \ y = t x\n \
\ z = t y\n \
\ variablewithamuchlongername = z\n \
\ variablewithamuchlongername"
let env = evalSapling Map.empty (parseSapling input)
(result env) @?= (Stem (Stem Leaf)) (result env) @?= (Stem (Stem Leaf))
, testCase "Evaluate redefinition of variables" $ do , testCase "Evaluate redefinition of variables" $ do
let input = "x = t t\nx = t\nx" let input = "x = t t\nx = t\nx"
let env = evalMulti Map.empty (parseMulti input) let env = evalSapling Map.empty (parseSapling input)
(result env) @?= Leaf (result env) @?= Leaf
] ]
@ -227,6 +247,5 @@ propertyTests = testGroup "Property Tests"
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 -> parseSapling input === ast Right ast -> parseSingle input === ast
] ]